Logo Search packages:      
Sourcecode: necpp version File versions  Download package

nec2dx.f

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 510-422-8414
C     FOR PROBLEMS WITH THE NEC CODE.)
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     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      PARAMETER (IRESRV=MAXMAT**2)
      IMPLICIT REAL*8(A-H,O-Z)
      CHARACTER AIN*2,ATST*2,INFILE*80,OUTFILE*80
C***
      REAL*8 HPOL,PNET
C      CHARACTER INMSG*48,OUTMSG*40
C      INTEGER*2 GPWNXY(2)
C      LOGICAL*4 GetPut,LGTPT
      COMPLEX*16  CM,FJ,VSANT,ETH,EPH,ZRATI,CUR,CURI,ZARRAY,ZRATI2
      COMPLEX*16  EX,EY,EZ,ZPED,VQD,VQDS,T1,Y11A,Y12A,EPSC,U,U2,XX1,XX2
      COMPLEX*16  AR1,AR2,AR3,EPSCF,FRATI
      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM
      COMMON /CMB/CM(IRESRV)
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,
     1ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
      COMMON/SAVE/EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(2*MAXSEG),KCOM
      COMMON/CSAVE/COM(19,5)
      COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),
     &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)
      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,
     &KSYMP,IFAR,IPERF
      COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF
      COMMON/YPARM/Y11A(5),Y12A(20),NCOUP,ICOUP,NCTAG(5),NCSEG(5)
      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,
     1IPCON(10),NPCON
      COMMON/VSORC/VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),
     1IQDS(30),NVQD,NSANT,NQDS
      COMMON/NETCX/ZPED,PIN,PNLS,X11R(30),X11I(30),X12R(30),X12I(30),
     &X22R(30),X22I(30),NTYP(30),ISEG1(30),ISEG2(30),NEQ,NPEQ,NEQ2,
     &NONET,NTSOL,NPRINT,MASYM
      COMMON/FPAT/THETS,PHIS,DTH,DPH,RFLD,GNOR,CLT,CHT,EPSR2,SIG2,
     &XPR6,PINR,PNLR,PLOSS,XNR,YNR,ZNR,DXNR,DYNR,DZNR,NTH,NPH,IPD,IAVP,
     &INOR,IAX,IXTYP,NEAR,NFEH,NRX,NRY,NRZ
      COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),
     1DYA(3),XSA(3),YSA(3),NXA(3),NYA(3)
      COMMON/GWAV/U,U2,XX1,XX2,R1,R2,ZMH,ZPH
C***
      COMMON /PLOT/ IPLP1,IPLP2,IPLP3,IPLP4
C***
      DIMENSION CAB(1),SAB(1),X2(1),Y2(1),Z2(1)
      DIMENSION LDTYP(300),LDTAG(300),LDTAGF(300),LDTAGT(300),ZLR(300),
     1ZLI(300),ZLC(300)
      DIMENSION ATST(22),PNET(6),HPOL(3),IX(2*MAXSEG)
      DIMENSION FNORM(200)
      DIMENSION T1X(1),T1Y(1),T1Z(1),T2X(1),T2Y(1),T2Z(1)
C***
      DIMENSION XTEMP(MAXSEG),YTEMP(MAXSEG),ZTEMP(MAXSEG),
     &SITEMP(MAXSEG),BITEMP(MAXSEG)
      EQUIVALENCE (CAB,ALP),(SAB,BET),(X2,SI),(Y2,ALP),(Z2,BET)
      EQUIVALENCE (T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),
     1 (T2Z,ITAG)
      DATA ATST/'CE','FR','LD','GN','EX','NT','XQ','NE','GD','RP','CM',
     1 '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/
      DATA LOADMX,NSMAX,NETMX/300,30,30/,NORMF/200/
706   CONTINUE
C
C     History:
C        Date      Change
C      -------     ----------------------------------------------
C      5/04/95     Matrix re-transposed in subroutine FACTR.
C                  FACTR and SOLVE changed for non-transposed matrix.
C
C      4/15/02     Increased limit for LD cards from 30 to 300
C
C      8/15/05     Changed to read from standard input and write to
C                  standard output.
C
C ********** READING FROM COMMAND LINE ARGUMENTS
      CALL GETARG(1,INFILE)
      OPEN (UNIT=2,FILE=INFILE,STATUS='OLD',ERR=702)
      CALL GETARG(2,OUTFILE)
      OPEN (UNIT=3,FILE=OUTFILE,STATUS='UNKNOWN',ERR=704)
      GO TO 705
702   CALL ERROR
      STOP
704   CALL ERROR
      STOP
C***MAC
C     OPEN IN AND OUT FILES WITH DIALOG BOX FOR MACINTOSH
C
C      INMSG='Select nec input file    (NEC-2D)               '
C      OUTMSG='Enter name of output file               '
C      GPWNXY(1)=50
C      GPWNXY(2)=100
C702   LGTPT= GetPut(1,GPWNXY,INMSG,INFILE,IVOL,1,'TEXT')
C      IF(.NOT.LGTPT)STOP
C      OPEN (UNIT=2,FILE=INFILE,STATUS='OLD',ACTION='READ',ERR=702)
C704   LGTPT= GetPut(0,GPWNXY,OUTMSG,OUTFILE,IVOL,1,'TEXT')
C      IF(.NOT.LGTPT)STOP
C      OPEN (UNIT=3,FILE=OUTFILE,STATUS='UNKNOWN',ERR=704)
C      WRITE(*,*)' NEC-2D RUN IN PROGRESS'
C***MAC
705   CONTINUE
      CALL SECOND(EXTIM)
      FJ=(0.,1.)
      LD=MAXSEG
      NXA(1)=0
1     KCOM=0
C***
      IFRTIMW=0
      IFRTIMP=0
C***
2     KCOM=KCOM+1
      IF (KCOM.GT.5) KCOM=5
      READ(2,125)AIN,(COM(I,KCOM),I=1,19)
      CALL UPCASE(AIN,AIN,LAIN)
      IF(KCOM.GT.1)GO TO 3
      WRITE(3,126)
      WRITE(3,127)
      WRITE(3,128)
3     WRITE(3,129) (COM(I,KCOM),I=1,19)
      IF (AIN.EQ.ATST(11)) GO TO 2
      IF (AIN.EQ.ATST(1)) GO TO 4
      WRITE(3,130)
      STOP
4     CONTINUE
      DO 5 I=1,LD
5     ZARRAY(I)=(0.,0.)
      MPCNT=0
      IMAT=0
C
C     SET UP GEOMETRY DATA IN SUBROUTINE DATAGN
C
      CALL DATAGN
      IFLOW=1
      IF(IMAT.EQ.0)GO TO 326
C
C     CORE ALLOCATION FOR ARRAYS B, C, AND D FOR N.G.F. SOLUTION
C
      NEQ=N1+2*M1
      NEQ2=N-N1+2*(M-M1)+NSCON+2*NPCON
      CALL FBNGF(NEQ,NEQ2,IRESRV,IB11,IC11,ID11,IX11)
      GO TO 6
326   NEQ=N+2*M
      NEQ2=0
      IB11=1
      IC11=1
      ID11=1
      IX11=1
      ICASX=0
6     NPEQ=NP+2*MP
      WRITE(3,135)
C
C     DEFAULT VALUES FOR INPUT PARAMETERS AND FLAGS
C
C***
      IPLP1=0
      IPLP2=0
      IPLP3=0
      IPLP4=0
C***
      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)GO TO 14
      FMHZ=CVEL
      NLODF=0
      KSYMP=1
      NRADL=0
      IPERF=0
C
C     MAIN INPUT SECTION - STANDARD READ STATEMENT - JUMPS TO APPRO-
C     PRIATE SECTION FOR SPECIFIC PARAMETER SET UP
C
14    CALL READMN(2,AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,TMP4,
     &TMP5,TMP6)
      MPCNT=MPCNT+1
      WRITE(3,137) MPCNT,AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,
     1TMP4,TMP5,TMP6
      IF (AIN.EQ.ATST(2)) GO TO 16
      IF (AIN.EQ.ATST(3)) GO TO 17
      IF (AIN.EQ.ATST(4)) GO TO 21
      IF (AIN.EQ.ATST(5)) GO TO 24
      IF (AIN.EQ.ATST(6)) GO TO 28
      IF (AIN.EQ.ATST(14)) GO TO 28
      IF (AIN.EQ.ATST(15)) GO TO 31
      IF (AIN.EQ.ATST(18)) GO TO 319
      IF (AIN.EQ.ATST(7)) GO TO 37
      IF (AIN.EQ.ATST(8)) GO TO 32
      IF (AIN.EQ.ATST(17)) GO TO 208
      IF (AIN.EQ.ATST(9)) GO TO 34
      IF (AIN.EQ.ATST(10)) GO TO 36
      IF (AIN.EQ.ATST(16)) GO TO 305
      IF (AIN.EQ.ATST(19)) GO TO 320
      IF (AIN.EQ.ATST(12)) GO TO 1
      IF (AIN.EQ.ATST(20)) GO TO 322
      IF (AIN.EQ.ATST(21)) GO TO 304
C***
      IF (AIN.EQ.ATST(22)) GO TO 330
C***
      IF (AIN.NE.ATST(13)) GO TO 15
      CALL SECOND(TMP1)
      TMP1=TMP1-EXTIM
      WRITE(3,201) TMP1
      STOP
15    WRITE(3,138)
      STOP
C
C     FREQUENCY PARAMETERS
C
16    IFRQ=ITMP1
      IF(ICASX.EQ.0)GO TO 8
      WRITE(3,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
      GO TO 14
C
C     MATRIX INTEGRATION LIMIT
C
305   RKH=TMP1
      IF(IGO.GT.2)IGO=2
      IFLOW=1
      GO TO 14
C
C     EXTENDED THIN WIRE KERNEL OPTION
C
320   IEXK=1
      IF(ITMP1.EQ.-1)IEXK=0
      IF(IGO.GT.2)IGO=2
      IFLOW=1
      GO TO 14
C
C     MAXIMUM COUPLING BETWEEN ANTENNAS
C
304   IF(IFLOW.NE.2)NCOUP=0
      ICOUP=0
      IFLOW=2
      IF(ITMP2.EQ.0)GO TO 14
      NCOUP=NCOUP+1
      IF(NCOUP.GT.5)GO TO 312
      NCTAG(NCOUP)=ITMP1
      NCSEG(NCOUP)=ITMP2
      IF(ITMP4.EQ.0)GO TO 14
      NCOUP=NCOUP+1
      IF(NCOUP.GT.5)GO TO 312
      NCTAG(NCOUP)=ITMP3
      NCSEG(NCOUP)=ITMP4
      GO TO 14
312   WRITE(3,313)
      STOP
C
C     LOADING PARAMETERS
C
17    IF (IFLOW.EQ.3) GO TO 18
      NLOAD=0
      IFLOW=3
      IF (IGO.GT.2) IGO=2
      IF (ITMP1.EQ.(-1)) GO TO 14
18    NLOAD=NLOAD+1
      IF (NLOAD.LE.LOADMX) GO TO 19
      WRITE(3,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) GO TO 20
      WRITE(3,140)  NLOAD,ITMP3,ITMP4
      STOP
20    ZLR(NLOAD)=TMP1
      ZLI(NLOAD)=TMP2
      ZLC(NLOAD)=TMP3
      GO TO 14
C
C     GROUND PARAMETERS UNDER THE ANTENNA
C
21    IFLOW=4
      IF(ICASX.EQ.0)GO TO 10
      WRITE(3,303) AIN
      STOP
10    IF (IGO.GT.2) IGO=2
      IF (ITMP1.NE.(-1)) GO TO 22
      KSYMP=1
      NRADL=0
      IPERF=0
      GO TO 14
22    IPERF=ITMP1
      NRADL=ITMP2
      KSYMP=2
      EPSR=TMP1
      SIG=TMP2
      IF (NRADL.EQ.0) GO TO 23
      IF(IPERF.NE.2)GO TO 314
      WRITE(3,390)
      STOP
314   SCRWLT=TMP3
      SCRWRT=TMP4
      GO TO 14
23    EPSR2=TMP3
      SIG2=TMP4
      CLT=TMP5
      CHT=TMP6
      GO TO 14
C
C     EXCITATION PARAMETERS
C
24    IF (IFLOW.EQ.5) GO TO 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) GO TO 27
      IXTYP=ITMP1
      NTSOL=0
      IF(IXTYP.EQ.0)GO TO 205
      NVQD=NVQD+1
      IF(NVQD.GT.NSMAX)GO TO 206
      IVQD(NVQD)=ISEGNO(ITMP2,ITMP3)
      VQD(NVQD)=DCMPLX(TMP1,TMP2)
      IF(ABS(VQD(NVQD)).LT.1.D-20)VQD(NVQD)=(1.,0.)
      GO TO 207
205   NSANT=NSANT+1
      IF (NSANT.LE.NSMAX) GO TO 26
206   WRITE(3,141)
      STOP
26    ISANT(NSANT)=ISEGNO(ITMP2,ITMP3)
      VSANT(NSANT)=DCMPLX(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
      GO TO 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
      GO TO 14
C
C     NETWORK PARAMETERS
C
28    IF (IFLOW.EQ.6) GO TO 29
      NONET=0
      NTSOL=0
      IFLOW=6
      IF (IGO.GT.3) IGO=3
      IF (ITMP2.EQ.(-1)) GO TO 14
29    NONET=NONET+1
      IF (NONET.LE.NETMX) GO TO 30
      WRITE(3,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.) GO TO 14
      NTYP(NONET)=3
      X11R(NONET)=-TMP1
      GO TO 14
C***
C
C     PLOT FLAGS
C
330   IPLP1=ITMP1
      IPLP2=ITMP2
      IPLP3=ITMP3
      IPLP4=ITMP4
      OPEN (UNIT=8,FILE='PLTDAT.NEC',STATUS='NEW',ERR=14)
C***
      GO TO 14
C
C     PRINT CONTROL FOR CURRENT
C
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
      GO TO 14
C
C     WRITE CONTROL FOR CHARGE
C
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
      GO TO 14
C
C     NEAR FIELD CALCULATION PARAMETERS
C
208   NFEH=1
      GO TO 209
32    NFEH=0
209   IF (.NOT.(IFLOW.EQ.8.AND.NFRQ.NE.1)) GO TO 33
      WRITE(3,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) GO TO 14
      GO TO (41,46,53,71,72), IGO
C
C     GROUND REPRESENTATION
C
34    EPSR2=TMP1
      SIG2=TMP2
      CLT=TMP3
      CHT=TMP4
      IFLOW=9
      GO TO 14
C
C     STANDARD OBSERVATION ANGLE PARAMETERS
C
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
      GO TO (41,46,53,71,78), IGO
C
C     WRITE NUMERICAL GREEN
































































































































'S FUNCTION TAPEC322   IFLOW=12      IF(ICASX.EQ.0)GO TO 301      WRITE(3,302)      STOP301   IRNGF=IRESRV/2      GO TO (41,46,52,52,52),IGOCC     EXECUTE CARD  -  CALC. INCLUDING RADIATED FIELDSC37    IF (IFLOW.EQ.10.AND.ITMP1.EQ.0) GO TO 14      IF (NFRQ.EQ.1.AND.ITMP1.EQ.0.AND.IFLOW.GT.7) GO TO 14      IF (ITMP1.NE.0) GO TO 39      IF (IFLOW.GT.7) GO TO 38      IFLOW=7      GO TO 4038    IFLOW=11      GO TO 4039    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) GO TO 40      NPH=2      DPH=90.40    GO TO (41,46,53,71,78), IGOCC     END OF THE MAIN INPUT SECTIONCC     BEGINNING OF THE FREQUENCY DO LOOPC41    MHZ=1C***        IF(N.EQ.0 .OR. IFRTIMW .EQ. 1)GO TO 406        IFRTIMW=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     CONTINUE406     IF(M.EQ.0 .OR. IFRTIMP .EQ. 1)GO TO 407        IFRTIMP=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     CONTINUE407     CONTINUE        FMHZ1=FMHZC***C     CORE ALLOCATION FOR PRIMARY INTERACTON MATRIX.  (A)      IF(IMAT.EQ.0)CALL FBLOCK(NPEQ,NEQ,IRESRV,IRNGF,IPSYM)42    IF (MHZ.EQ.1) GO TO 44      IF (IFRQ.EQ.1) GO TO 43C      FMHZ=FMHZ+DELFRQC***      FMHZ=FMHZ1+(MHZ-1)*DELFRQ      GO TO 4443    FMHZ=FMHZ*DELFRQ44    FR=FMHZ/CVELC***      WLAM=CVEL/FMHZ      WRITE(3,145)  FMHZ,WLAM      WRITE(3,196) RKH      IF(IEXK.EQ.1)WRITE(3,321)C     FREQUENCY SCALING OF GEOMETRIC PARAMETERSC***      FMHZS=FMHZ      IF(N.EQ.0)GO TO 306      DO 45 I=1,NC***      X(I)=XTEMP(I)*FR      Y(I)=YTEMP(I)*FR      Z(I)=ZTEMP(I)*FR      SI(I)=SITEMP(I)*FR45    BI(I)=BITEMP(I)*FRC***306   IF(M.EQ.0)GO TO 307      FR2=FR*FR      J=LD+1      DO 245 I=1,M      J=J-1C***      X(J)=XTEMP(J)*FR      Y(J)=YTEMP(J)*FR      Z(J)=ZTEMP(J)*FR245   BI(J)=BITEMP(J)*FR2C***307   IGO=2C     STRUCTURE SEGMENT LOADING46    WRITE(3,146)      IF(NLOAD.NE.0) CALL LOAD(LDTYP,LDTAG,LDTAGF,LDTAGT,ZLR,ZLI,ZLC)      IF(NLOAD.EQ.0.AND.NLODF.EQ.0)WRITE(3,147)      IF(NLOAD.EQ.0.AND.NLODF.NE.0)WRITE(3,327)C     GROUND PARAMETER      WRITE(3,148)      IF (KSYMP.EQ.1) GO TO 49      FRATI=(1.,0.)      IF (IPERF.EQ.1) GO TO 48      IF(SIG.LT.0.)SIG=-SIG/(59.96*WLAM)      EPSC=DCMPLX(EPSR,-SIG*WLAM*59.96)      ZRATI=1./SQRT(EPSC)      U=ZRATI      U2=U*U      IF (NRADL.EQ.0) GO TO 47      SCRWL=SCRWLT/WLAM      SCRWR=SCRWRT/WLAM      T1=FJ*2367.067D+0/DFLOAT(NRADL)      T2=SCRWR*DFLOAT(NRADL)      WRITE(3,170)  NRADL,SCRWLT,SCRWRT      WRITE(3,149)47    IF(IPERF.EQ.2)GO TO 328      WRITE(3,391)      GO TO 329328   IF(NXA(1).EQ.0)THEN         OPEN(UNIT=21,FILE='SOM2D.NEC',STATUS='OLD',FORM='UNFORMATTED





































































































































































































































































































',     &   ERR=800)         GO TO 801800      WRITE(3,900)         STOP801      READ(21)AR1,AR2,AR3,EPSCF,DXA,DYA,XSA,YSA,NXA,NYA      END IF      FRATI=(EPSC-1.)/(EPSC+1.)      IF(ABS((EPSCF-EPSC)/EPSC).LT.1.D-3)GO TO 400      WRITE(3,393) EPSCF,EPSC      STOP400   WRITE(3,392)329   WRITE(3,150)  EPSR,SIG,EPSC      GO TO 5048    WRITE(3,151)      GO TO 5049    WRITE(3,152)50    CONTINUEC * * *C     FILL AND FACTOR PRIMARY INTERACTION MATRIXC      CALL SECOND (TIM1)      IF(ICASX.NE.0)GO TO 324      CALL CMSET(NEQ,CM,RKH,IEXK)      CALL SECOND (TIM2)      TIM=TIM2-TIM1      CALL FACTRS(NPEQ,NEQ,CM,IP,IX,11,12,13,14)      GO TO 323CC     N.G.F. - FILL B, C, AND D AND FACTOR D-C(INV(A)B)CC ****324   IF(NEQ2.EQ.0)GO TO 333C ****      CALL CMNGF(CM(IB11),CM(IC11),CM(ID11),NPBX,NEQ,NEQ2,RKH,IEXK)      CALL SECOND (TIM2)      TIM=TIM2-TIM1      CALL FACGF(CM,CM(IB11),CM(IC11),CM(ID11),CM(IX11),IP,IX,NP,N1,MP,     1M1,NEQ,NEQ2)323   CALL SECOND (TIM1)      TIM2=TIM1-TIM2      WRITE(3,153)  TIM,TIM2333   IGO=3      NTSOL=0      IF(IFLOW.NE.12)GO TO 53C     WRITE N.G.F. FILE52    CALL GFOUT      GO TO 14CC     EXCITATION SET UP (RIGHT HAND SIDE, -E INC.)C53    NTHIC=1      NPHIC=1      INC=1      NPRINT=054    IF (IXTYP.EQ.0.OR.IXTYP.EQ.5) GO TO 56      IF (IPTFLG.LE.0.OR.IXTYP.EQ.4) WRITE(3,154)      TMP5=TA*XPR5      TMP4=TA*XPR4      IF (IXTYP.NE.4) GO TO 55      TMP1=XPR1/WLAM      TMP2=XPR2/WLAM      TMP3=XPR3/WLAM      TMP6=XPR6/(WLAM*WLAM)      WRITE(3,156)  XPR1,XPR2,XPR3,XPR4,XPR5,XPR6      GO TO 5655    TMP1=TA*XPR1      TMP2=TA*XPR2      TMP3=TA*XPR3      TMP6=XPR6      IF (IPTFLG.LE.0) WRITE(3,155)  XPR1,XPR2,XPR3,HPOL(IXTYP),XPR656    CALL ETMNS (TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,IXTYP,CUR)CC     MATRIX SOLVING  (NETWK CALLS SOLVES)C      IF (NONET.EQ.0.OR.INC.GT.1) GO TO 60      WRITE(3,158)      ITMP3=0      ITMP1=NTYP(1)      DO 59 I=1,2      IF (ITMP1.EQ.3) ITMP1=2      IF (ITMP1.EQ.2) WRITE(3,159)      IF (ITMP1.EQ.1) WRITE(3,160)      DO 58 J=1,NONET      ITMP2=NTYP(J)      IF ((ITMP2/ITMP1).EQ.1) GO TO 57      ITMP3=ITMP2      GO TO 5857    ITMP4=ISEG1(J)      ITMP5=ISEG2(J)      IF (ITMP2.GE.2.AND.X11I(J).LE.0.) X11I(J)=WLAM*SQRT((X(ITMP5)-     1 X(ITMP4))**2+(Y(ITMP5)-Y(ITMP4))**2+(Z(ITMP5)-Z(ITMP4))**2)      WRITE(3,157)  ITAG(ITMP4),ITMP4,ITAG(ITMP5),ITMP5,X11R(J),X11     1I(J),X12R(J),X12I(J),X22R(J),X22I(J),PNET(2*ITMP2-1),PNET(2*ITMP2)58    CONTINUE      IF (ITMP3.EQ.0) GO TO 60      ITMP1=ITMP359    CONTINUE60    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) GO TO 61      ITMP1=MHZ+4*(MHZ-1)      IF (ITMP1.GT.(NORMF-3)) GO TO 61      FNORM(ITMP1)=DREAL(ZPED)      FNORM(ITMP1+1)=DIMAG(ZPED)      FNORM(ITMP1+2)=ABS(ZPED)      FNORM(ITMP1+3)=CANG(ZPED)      IF (IPED.EQ.2) GO TO 61      IF (FNORM(ITMP1+2).GT.ZPNORM) ZPNORM=FNORM(ITMP1+2)61    CONTINUECC     PRINTING STRUCTURE CURRENTSC      IF(N.EQ.0)GO TO 308      IF (IPTFLG.EQ.(-1)) GO TO 63      IF (IPTFLG.GT.0) GO TO 62      WRITE(3,161)      WRITE(3,162)      GO TO 6362    IF (IPTFLG.EQ.3.OR.INC.GT.1) GO TO 63      WRITE(3,163)  XPR3,HPOL(IXTYP),XPR663    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) GO TO 64      IF (ABS(DREAL(ZARRAY(I))).LT.1.D-20) GO TO 64      PLOSS=PLOSS+.5*CMAG*CMAG*DREAL(ZARRAY(I))*SI(I)64    IF (JUMP) 68,69,6565    IF (IPTAG.EQ.0) GO TO 66      IF (ITAG(I).NE.IPTAG) GO TO 6966    ITMP1=ITMP1+1      IF (ITMP1.LT.IPTAGF.OR.ITMP1.GT.IPTAGT) GO TO 69      IF (IPTFLG.EQ.0) GO TO 68      IF (IPTFLG.LT.2.OR.INC.GT.NORMF) GO TO 67      FNORM(INC)=CMAG      ISAVE=I67    IF (IPTFLG.NE.3) WRITE(3,164)  XPR1,XPR2,CMAG,PH,I      GO TO 6968    WRITE(3,165)  I,ITAG(I),X(I),Y(I),Z(I),SI(I),CURI,CMAG,PHC***      IF(IPLP1 .NE. 1) GO TO 69      IF(IPLP2 .EQ. 1) WRITE(8,*) CURI      IF(IPLP2 .EQ. 2) WRITE(8,*) CMAG,PHC***69    CONTINUE      IF(IPTFLQ.EQ.(-1))GO TO 308      WRITE(3,315)      ITMP1=0      FR=1.D-6/FMHZ      DO 316 I=1,N      IF(IPTFLQ.EQ.(-2))GO TO 318      IF(IPTAQ.EQ.0)GO TO 317      IF(ITAG(I).NE.IPTAQ)GO TO 316317   ITMP1=ITMP1+1      IF(ITMP1.LT.IPTAQF.OR.ITMP1.GT.IPTAQT)GO TO 316318   CURI=FR*DCMPLX(-BII(I),BIR(I))      CMAG=ABS(CURI)      PH=CANG(CURI)      WRITE(3,165) I,ITAG(I),X(I),Y(I),Z(I),SI(I),CURI,CMAG,PH316   CONTINUE308   IF(M.EQ.0)GO TO 310      WRITE(3,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)      EPHA=CANG(EPH)C309   WRITE(3,198) I,X(ITMP1),Y(ITMP1),Z(ITMP1),ETHM,ETHA,EPHM,EPHA,EC     1X,EY, EZC***      WRITE(3,198) I,X(ITMP1),Y(ITMP1),Z(ITMP1),ETHM,ETHA,EPHM,EPHA,E     1X,EY,EZ      IF(IPLP1 .NE. 1) GO TO 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,EZ309   CONTINUEC***310   IF (IXTYP.NE.0.AND.IXTYP.NE.5) GO TO 70      TMP1=PIN-PNLS-PLOSS      TMP2=100.*TMP1/PIN      WRITE(3,166)  PIN,TMP1,PLOSS,PNLS,TMP270    CONTINUE      IGO=4      IF(NCOUP.GT.0)CALL COUPLE(CUR,WLAM)      IF (IFLOW.NE.7) GO TO 71      IF (IXTYP.GT.0.AND.IXTYP.LT.4) GO TO 113      IF (NFRQ.NE.1) GO TO 120      WRITE(3,135)      GO TO 1471    IGO=5CC     NEAR FIELD CALCULATIONC72    IF (NEAR.EQ.(-1)) GO TO 78      CALL NFPAT      IF (MHZ.EQ.NFRQ) NEAR=-1      IF (NFRQ.NE.1) GO TO 78      WRITE(3,135)      GO TO 14CC     STANDARD FAR FIELD CALCULATIONC78    IF(IFAR.EQ.-1)GO TO 113      PINR=PIN      PNLR=PNLS      CALL RDPAT113   IF (IXTYP.EQ.0.OR.IXTYP.GE.4) GO TO 119      NTHIC=NTHIC+1      INC=INC+1      XPR1=XPR1+XPR4      IF (NTHIC.LE.NTHI) GO TO 54      NTHIC=1      XPR1=THETIS      XPR2=XPR2+XPR5      NPHIC=NPHIC+1      IF (NPHIC.LE.NPHI) GO TO 54      NPHIC=1      XPR2=PHISS      IF (IPTFLG.LT.2) GO TO 119C     NORMALIZED RECEIVING PATTERN PRINTED      ITMP1=NTHI*NPHI      IF (ITMP1.LE.NORMF) GO TO 114      ITMP1=NORMF      WRITE(3,181)114   TMP1=FNORM(1)      DO 115 J=2,ITMP1      IF (FNORM(J).GT.TMP1) TMP1=FNORM(J)115   CONTINUE      WRITE(3,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) GO TO 117      TMP2=FNORM(ITMP3)/TMP1      TMP3=DB20(TMP2)      WRITE(3,183)  XPR1,XPR2,TMP3,TMP2      XPR1=XPR1+XPR4116   CONTINUE117   XPR1=THETIS      XPR2=XPR2+XPR5118   CONTINUE      XPR2=PHISS119   IF (MHZ.EQ.NFRQ) IFAR=-1      IF (NFRQ.NE.1) GO TO 120      WRITE(3,135)      GO TO 14120   MHZ=MHZ+1      IF (MHZ.LE.NFRQ) GO TO 42      IF (IPED.EQ.0) GO TO 123      IF(NVQD.LT.1)GO TO 199      WRITE(3,184) IVQD(NVQD),ZPNORM      GO TO 204199   WRITE(3,184)  ISANT(NSANT),ZPNORM204   ITMP1=NFRQ      IF (ITMP1.LE.(NORMF/4)) GO TO 121      ITMP1=NORMF/4      WRITE(3,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(3,186)  TMP1,FNORM(ITMP2),FNORM(ITMP2+1),FNORM(ITMP2+2),     1FNORM(ITMP2+3),TMP2,TMP3,TMP4,TMP5      IF (IFRQ.EQ.0) TMP1=TMP1+DELFRQ      IF (IFRQ.EQ.1) TMP1=TMP1*DELFRQ122   CONTINUE      WRITE(3,135)123   CONTINUE      NFRQ=1      MHZ=1      GO TO 14125   FORMAT (A2,19A4)126   FORMAT  ('1
')127   FORMAT (///,33X,'*********************************************
',     &//,36X,'NUMERICAL ELECTROMAGNETICS CODE (NEC-2D)
',//,33X,     2 '*********************************************
')128   FORMAT (////,37X,'- - - - COMMENTS - - - -

',//)129   FORMAT (25X,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),     1 6(1X,1P,E12.5))138   FORMAT (///,10X,'FAULTY DATA CARD LABEL AFTER GEOMETRY SECTION
')139   FORMAT (///,10X,'NUMBER OF LOADING CARDS EXCEEDS STORAGE ALLOTTED

'     1)140   FORMAT (///,10X,'DATA FAULT ON LOADING CARD NO.=
',I5,5X,     &'ITAG STEP1=',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 ALLOTTE
',     &'D
')143   FORMAT(///,10X,'WHEN MULTIPLE FREQUENCIES ARE REQUESTED, ONLY ON
',     &'E NEAR FIELD CARD CAN BE USED -',/,10X,'LAST CARD READ IS USED
')145   FORMAT (////,33X,'- - - - - - FREQUENCY - - - - - -
',//,36X,     &'FREQUENCY=',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,     1' 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,     1'X',12X,'Y',12X,'Z',10X,'ALPHA',5X,'BETA',4X,'DIPOLE MOMENT
',//     2 ,4X,'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.
'     2,'   TAG  SEG.',6X,'IMPEDANCE',6X,'LENGTH',12X,'- END ONE -
',17X,     3'- END TWO -',12X,'TYPE',/,6X,'NO.   NO.   NO.   NO.',9X,'OHMS
',     &8X,'METERS',9X,'REAL',10X,'IMAG.',9X,'REAL',10X,'IMAG.
')160   FORMAT (/,6X,'- FROM -',4X,'- TO -',26X,'-  -  ADMITTANCE MATRIX
',     1' ELEMENTS (MHOS)  -  -',/,6X,'TAG  SEG.   TAG  SEG.',13X,'(ON
',     2'E,ONE)',19X,'(ONE,TWO)',19X,'(TWO,TWO)',/ ,6X,'NO.   NO.   NO
',     3'.   NO.',8X,'REAL',10X,'IMAG.',9X,'REAL',10X,'IMAG.',9X,'REAL
',     4 10X,'IMAG.
')161   FORMAT (///,29X,'- - - CURRENTS AND LOCATION - - -
',//,33X,     &'DISTANCES IN WAVELENGTHS
')162   FORMAT (  //,2X,'SEG.',2X,'TAG',4X,'COORD. OF SEG. CENTER
',5X,     1 'SEG.',12X,'- - - CURRENT (AMPS) - - -',/,2X,'NO.',3X,'NO.
',     2 5X,'X',8X,'Y',8X,'Z',6X,'LENGTH',5X,'REAL',8X,'IMAG.',7X,'MAG.
',     3 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 POWER   =
     &',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,     1'WIRE LENGTH=',F8.2,' METERS',/,40X,'WIRE RADIUS=
',1P,E10.3,     2' METERS
')181   FORMAT (///,4X,'RECEIVING PATTERN STORAGE TOO SMALL,ARRAY TRUNCA
',     1'TED
')182   FORMAT (///,32X,'- - - NORMALIZED RECEIVING PATTERN - - -
',/,41X,     1'NORMALIZATION FACTOR=',1P,E11.4,/,41X,'ETA=',0P,F7.2,' DEGREES
',     2/,41X,'TYPE -',A6,/,41X,'AXIAL RATIO=',F6.3,/,41X,'SEGMENT NO.=
',     3I5,//,21X,'THETA',6X,'PHI',9X,'-  PATTERN  -',/,21X,'(DEG)
',5X,     4'(DEG)',8X,'DB',8X,'MAGNITUDE









































',/)183   FORMAT (20X,2(F7.2,3X),1X,F7.2,4X,1P,E11.4)184   FORMAT (///,36X,32H- - - INPUT IMPEDANCE DATA - - -,/   ,45X,18HSO     1URCE SEGMENT NO.,I4,/  ,45X,21HNORMALIZATION FACTOR=,1P,E12.5,//     2,7X,5HFREQ.,13X,34H-  -  UNNORMALIZED IMPEDANCE  -  -,21X,   32H-      3 -  NORMALIZED IMPEDANCE  -  -,/    ,19X,10HRESISTANCE,4X,9HREACTA     4NCE,6X,9HMAGNITUDE,4X,5HPHASE,7X,10HRESISTANCE,4X,9HREACTANCE,6X,     5 9HMAGNITUDE,4X,5HPHASE,/    ,8X,3HMHZ,11X,4HOHMS,10X,4HOHMS,11X,     6 4HOHMS,5X,7HDEGREES,47X,7HDEGREES,/)185   FORMAT (///,4X,62HSTORAGE FOR IMPEDANCE NORMALIZATION TOO SMALL, A     1RRAY TRUNCATED)186   FORMAT (3X,F9.3,2X,1P,2(2X,E12.5),3X,E12.5,2X,0P,F7.2,2X,1P,2(2X,     1 E12.5),3X,E12.5,2X,0P,F7.2)196   FORMAT(   ////,20X,55HAPPROXIMATE INTEGRATION EMPLOYED FOR SEGMENT     1S MORE THAN,F8.3,18H WAVELENGTHS APART)197   FORMAT(   ////,41X,38H- - - - SURFACE PATCH CURRENTS - - - -,//,     1 50X,23HDISTANCE IN WAVELENGTHS,/,50X,21HCURRENT IN AMPS/METER,     1 //,28X,26H- - SURFACE COMPONENTS - -,19X,34H- - - RECTANGULAR COM     1PONENTS - - -,/,6X,12HPATCH CENTER,6X,16HTANGENT VECTOR 1,3X,     116HTANGENT VECTOR 2,11X,1HX,19X,1HY,19X,1HZ,/,5X,1HX,6X,1HY,6X,     11HZ,5X,4HMAG.,7X,5HPHASE,3X,4HMAG.,7X,5HPHASE,3(4X,4HREAL,6X,     1 6HIMAG. ))198   FORMAT(1X,I4,/,1X,3F7.3,2(1P,E11.4,0P,F8.2),1P,6E10.2)201   FORMAT(/,11H RUN TIME =,F10.3)315   FORMAT(///,34X,28H- - - CHARGE DENSITIES - - -,//,36X,     1 24HDISTANCES IN WAVELENGTHS,///,2X,4HSEG.,2X,3HTAG,4X,     2 21HCOORD. OF SEG. CENTER,5X,4HSEG.,10X,     3 31HCHARGE DENSITY (COULOMBS/METER),/,2X,3HNO.,3X,3HNO.,5X,1HX,8X,     4 1HY,8X,1HZ,6X,6HLENGTH,5X,4HREAL,8X,5HIMAG.,7X,4HMAG.,8X,5HPHASE)321   FORMAT( /,20X,42HTHE EXTENDED THIN WIRE KERNEL WILL BE USED)303   FORMAT(/,9H ERROR - ,A2,32H CARD IS NOT ALLOWED WITH N.G.F.)327   FORMAT(/,35X,31H LOADING ONLY IN N.G.F. SECTION)302   FORMAT(48H ERROR - N.G.F. IN USE.  CANNOT WRITE NEW N.G.F.)313   FORMAT(/,62H NUMBER OF SEGMENTS IN COUPLING CALCULATION (CP) EXCEE     1DS LIMIT)390   FORMAT(78H RADIAL WIRE G. S. APPROXIMATION MAY NOT BE USED WITH SO     1MMERFELD GROUND OPTION)391   FORMAT(40X,52HFINITE GROUND.  REFLECTION COEFFICIENT APPROXIMATION     1)392   FORMAT(40X,35HFINITE GROUND.  SOMMERFELD SOLUTION)393   FORMAT(/,29H ERROR IN GROUND PARAMETERS -,/,41H COMPLEX DIELECTRIC     1 CONSTANT FROM FILE IS,1P,2E12.5,/,32X,9HREQUESTED,2E12.5)900   FORMAT(' ERROR OPENING SOMMERFELD GROUND FILE - SOM2D.NEC





')      END      SUBROUTINE ARC (ITG,NS,RADA,ANG1,ANG2,RAD)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC




























































































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     ARC GENERATES SEGMENT GEOMETRY DATA FOR AN ARC OF NS SEGMENTSC      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,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) GO TO 1      WRITE(3,3)      STOP1     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)=RAD2     ITAG(I)=ITG      RETURNC3     FORMAT (40H ERROR -- ARC ANGLE EXCEEDS 360. DEGREES)      END      FUNCTION ATGN2 (X,Y)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***CC     ATGN2 IS ARCTANGENT FUNCTION MODIFIED TO RETURN 0. WHEN X=Y=0.C      IF (X) 3,1,31     IF (Y) 3,2,32     ATGN2=0.      RETURN3     ATGN2=ATAN2(X,Y)      RETURN      END      SUBROUTINE BLCKOT (AR,NUNIT,IX1,IX2,NBLKS,NEOF)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***CC     BLCKOT CONTROLS THE READING AND WRITING OF MATRIX BLOCKS ON FILESC     FOR THE OUT-OF-CORE MATRIX SOLUTION.C      COMPLEX*16 AR      DIMENSION AR(1)      I1=(IX1+1)/2      I2=(IX2+1)/21     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      READ (NUNIT,END=3) (AR(J),J=I1,I2)2     CONTINUE      RETURN3     WRITE(3,4)  NUNIT,NBLKS,NEOF      IF (NEOF.NE.777) STOP      NEOF=0      RETURNC4     FORMAT (13H  EOF ON UNIT,I3,9H  NBLKS= ,I3,8H  NEOF= ,I5)      END      SUBROUTINE CABC (CURX)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC



































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     CABC COMPUTES COEFFICIENTS OF THE CONSTANT (A), SINE (B), ANDC     COSINE (C) TERMS IN THE CURRENT INTERPOLATION FUNCTIONS FOR THEC     CURRENT VECTOR CUR.C      COMPLEX*16 CUR,CURX,VQDS,CURD,CCJ,VSANT,VQD,CS1,CS2      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),     &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP     1CON(10),NPCON      COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS(     130),NVQD,NSANT,NQDS      COMMON /ANGL/ SALP(MAXSEG)      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,ICON     12), (T2Z,ITAG)      EQUIVALENCE (CCJ,CCJX)      DATA TP/6.283185308D+0/,CCJX/0.,-0.01666666667D+0/      IF (N.EQ.0) GO TO 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=DREAL(CURX(I))      AI=DIMAG(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)*AR2     CII(J)=CII(J)+CX(JX)*AI      IF (NQDS.EQ.0) GO TO 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(     1JSNO)*SIN(TP*SH))*WLAM)      AR=DREAL(CURD)      AI=DIMAG(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)*AR3     CII(J)=CII(J)+CX(JX)*AI4     DO 5 I=1,N5     CURX(I)=DCMPLX(AIR(I)+CIR(I),AII(I)+CII(I))6     IF (M.EQ.0) RETURNC     CONVERT SURFACE CURRENTS FROM T1,T2 COMPONENTS TO X,Y,Z COMPONENTS      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      FUNCTION CANG (Z)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***CC     CANG RETURNS THE PHASE ANGLE OF A COMPLEX NUMBER IN DEGREES.C      COMPLEX*16 Z      CANG=ATGN2(DIMAG(Z),DREAL(Z))*57.29577951D+0      RETURN      END      SUBROUTINE CMNGF (CB,CC,CD,NB,NC,ND,RKHX,IEXKX)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC












































































































































































































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***C     CMNGF FILLS INTERACTION MATRICIES B, C, AND D FOR N.G.F. SOLUTION      COMPLEX*16 CB,CC,CD,ZARRAY,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP     1CON(10),NPCON      COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,     &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I     1CASX,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) GO TO 1      REWIND 12      REWIND 14      REWIND 15      IF (ICASX.GT.2) GO TO 51     DO 4 J=1,ND      DO 2 I=1,ND2     CD(I,J)=(0.,0.)      DO 3 I=1,NB      CB(I,J)=(0.,0.)3     CC(I,J)=(0.,0.)4     CONTINUE5     IST=N-N1+1      IT=NPBX      ISV=-NPBXC     LOOP THRU 24 FILLS B.  FOR ICASX=1 OR 2 ALSO FILLS D(WW), D(WS)      DO 24 IBLK=1,NBBX      ISV=ISV+NPBX      IF (IBLK.EQ.NBBX) IT=NLBX      IF (ICASX.LT.3) GO TO 7      DO 6 J=1,ND      DO 6 I=1,IT6     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      IF (N2.GT.N) GO TO 12C     FILL B(WW),B(WS).  FOR ICASX=1,2 FILL D(WW),D(WS)      DO 11 J=N2,N      CALL TRIO (J)      DO 9 I=1,JSNO      JSS=JCO(I)      IF (JSS.LT.N2) GO TO 8C     SET JCO WHEN SOURCE IS NEW BASIS FUNCTION ON NEW SEGMENT      JCO(I)=JSS-N1      GO TO 9C     SOURCE IS PORTION OF MODIFIED BASIS FUNCTION ON NEW SEGMENT8     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) GO TO 11      CALL CMWW (J,N2,N,CD,ND,CD,ND,1)      IF (M2.LE.M) CALL CMWS (J,M2EQ,MEQ,CD(1,IST),ND,CD,ND,1)C     LOADING IN D(WW)      IF (NLOAD.EQ.0) GO TO 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))*EXK11    CONTINUE12    IF (NSCON.EQ.0) GO TO 20C     FILL B(WW)PRIME      DO 19 I=1,NSCON      J=ISCON(I)C     SOURCES ARE NEW OR MODIFIED BASIS FUNCTIONS ON OLD SEGMENTS WHICHC     CONNECT TO NEW SEGMENTS      CALL TRIO (J)      JSS=0      DO 15 IX=1,JSNO      IR=JCO(IX)      IF (IR.LT.N2) GO TO 13      IR=IR-N1      GO TO 1413    IR=ICONX(IR)      IF (IR.EQ.0) GO TO 15      IR=NEQS+IR14    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)      IF (IM1.LE.IM2) CALL CMWS (J,IM1,IM2,CB(IMX,1),NB,CB,NB,0)C     SOURCE IS SINGULAR COMPONENT OF PATCH CURRENT THAT IS PART OFC     MODIFIED BASIS FUNCTION FOR OLD SEGMENT THAT CONNECTS TO A NEWC     SEGMENT ON END OPPOSITE PATCH.      IF (I1.LE.IN2) CALL CMSW (J,I,I1,IN2,CB,CB,0,NB,-1)      IF (NLODF.EQ.0) GO TO 17      JX=J-ISV      IF (JX.LT.1.OR.JX.GT.IT) GO TO 17      EXK=ZARRAY(J)      DO 16 IX=1,JSNO      JSS=JCO(IX)16    CB(JX,JSS)=CB(JX,JSS)-(AX(IX)+CX(IX))*EXKC     SOURCES ARE PORTIONS OF MODIFIED BASIS FUNCTION J ON OLD SEGMENTSC     EXCLUDING OLD SEGMENTS THAT DIRECTLY CONNECT TO NEW SEGMENTS.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) GO TO 18      IR=JCO(IX)      AX(1)=AX(IX)      BX(1)=BX(IX)      CX(1)=CX(IX)18    IF (IR.GT.N1) GO TO 19      IF (ICONX(IR).NE.0) GO TO 19      IF (I1.LE.IN2) CALL CMWW (IR,I1,IN2,CB,NB,CB,NB,0)      IF (IM1.LE.IM2) CALL CMWS (IR,IM1,IM2,CB(IMX,1),NB,CB,NB,0)C     LOADING FOR B(WW)PRIME      IF (NLODF.EQ.0) GO TO 19      JX=IR-ISV      IF (JX.LT.1.OR.JX.GT.IT) GO TO 19      EXK=ZARRAY(IR)      JSS=JCO(1)      CB(JX,JSS)=CB(JX,JSS)-(AX(1)+CX(1))*EXK19    CONTINUE20    IF (NPCON.EQ.0) GO TO 22      JSS=NEQPC     FILL B(SS)PRIME TO SET OLD PATCH BASIS FUNCTIONS TO ZERO FORC     PATCHES THAT CONNECT TO NEW SEGMENTS      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    CONTINUE22    IF (M2.GT.M) GO TO 23C     FILL B(SW) AND B(SS)      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) GO TO 24      WRITE (14) ((CB(I,J),I=1,IT),J=1,ND)24    CONTINUEC     FILLING B COMPLETE.  START ON C AND D      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) GO TO 27      DO 26 J=1,IT      DO 25 I=1,NC25    CC(I,J)=(0.,0.)      DO 26 I=1,ND26    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) GO TO 32      IF (N2.GT.N) GO TO 32C     SAME AS DO 24 LOOP TO FILL D(WW) FOR ICASX GREATER THAN 2      DO 31 J=N2,N      CALL TRIO (J)      DO 29 I=1,JSNO      JSS=JCO(I)      IF (JSS.LT.N2) GO TO 28      JCO(I)=JSS-N1      GO TO 2928    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) GO TO 31      IR=J-N1-ISV      IF (IR.LT.1.OR.IR.GT.IT) GO TO 31      EXK=ZARRAY(J)      DO 30 I=1,JSNO      JSS=JCO(I)30    CD(JSS,IR)=CD(JSS,IR)-(AX(I)+CX(I))*EXK31    CONTINUE32    IF (M2.GT.M) GO TO 33C     FILL D(SW) AND D(SS)      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)33    IF (N1.LT.1) GO TO 39C     FILL C(WW),C(WS), D(WW)PRIME, AND D(WS)PRIME.      DO 37 J=1,N1      CALL TRIO (J)      IF (NSCON.EQ.0) GO TO 36      DO 35 IX=1,JSNO      JSS=JCO(IX)      IF (JSS.LT.N2) GO TO 34      JCO(IX)=JSS+M1EQ      GO TO 3534    IR=ICONX(JSS)      IF (IR.NE.0) JCO(IX)=NEQSP+IR35    CONTINUE36    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     1)37    CONTINUE      IF (NSCON.EQ.0) GO TO 39C     FILL C(WW)PRIME      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    CONTINUE39    IF (NPCON.EQ.0) GO TO 41      JSS=NEQP-ISVC     FILL C(SS)PRIME      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    CONTINUE41    IF (M1.LT.1) GO TO 42C     FILL C(SW) AND C(SS)      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) GO TO 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      SUBROUTINE CMSET (NROW,CM,RKHX,IEXKX)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC
















































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     CMSET SETS UP THE COMPLEX STRUCTURE MATRIX IN THE ARRAY CMC      COMPLEX*16 CM,ZARRAY,ZAJ,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,SSX,     &D,DETER      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I     1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL      COMMON /SMAT/ SSX(16,16)      COMMON /SCRATM/ D(2*MAXSEG)      COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP     1CON(10),NPCON      COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,     &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,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      IT=NPBLKCC     CYCLE OVER MATRIX BLOCKSC      DO 13 IXBLK1=1,NBLOKS      ISV=(IXBLK1-1)*NPBLK      IF (IXBLK1.EQ.NBLOKS) IT=NLAST      DO 1 I=1,NROW      DO 1 J=1,IT1     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      IF (N.EQ.0) GO TO 5CC     WIRE SOURCE LOOPC      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)      IF (NLOAD.EQ.0) GO TO 4CC     MATRIX ELEMENTS MODIFIED BY LOADINGC      IF (J.GT.NP) GO TO 4      IPR=J-ISV      IF (IPR.LT.1.OR.IPR.GT.IT) GO TO 4      ZAJ=ZARRAY(J)      DO 3 I=1,JSNO      JSS=JCO(I)3     CM(JSS,IPR)=CM(JSS,IPR)-(AX(I)+CX(I))*ZAJ4     CONTINUE5     IF (M.EQ.0) GO TO 7C     MATRIX ELEMENTS FOR PATCH CURRENT SOURCES      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     CONTINUE7     IF (ICASE.EQ.1) GO TO 13      IF (ICASE.EQ.3) GO TO 12C     COMBINE ELEMENTS FOR SYMMETRY MODES      DO 11 I=1,IT      DO 11 J=1,NPEQ      DO 8 K=1,NOP      KA=J+(K-1)*NPEQ8     D(K)=CM(KA,I)      DETER=D(1)      DO 9 KK=2,NOP9     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,NOP10    DETER=DETER+D(KK)*SSX(K,KK)      CM(KA,I)=DETER11    CONTINUE      IF (ICASE.LT.3) GO TO 13C     WRITE BLOCK FOR OUT-OF-CORE CASES.12    CALL BLCKOT (CM,11,1,IOUT,1,31)13    CONTINUE      IF (ICASE.GT.2) REWIND 11      RETURN      END      SUBROUTINE CMSS (J1,J2,IM1,IM2,CM,NROW,ITRP)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC




















































































'      IMPLICIT REAL*8(A-H,O-Z)C ***C     CMSS COMPUTES MATRIX ELEMENTS FOR SURFACE-SURFACE INTERACTIONS.      COMPLEX*16 G11,G12,G21,G22,CM,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /ANGL/ SALP(MAXSEG)      COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,     &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,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,ICON     12), (T2Z,ITAG)      EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y     1J,IND1), (T2ZJ,IND2)      LDP=LD+1      I1=(IM1+1)/2      I2=(IM2+1)/2      ICOMP=I1*2-3      II1=-1      IF (ICOMP+2.LT.IM1) II1=-2C     LOOP OVER OBSERVATION PATCHES      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)      JJ1=-1C     LOOP OVER SOURCE PATCHES      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) GO TO 1      G11=G11-.5      G22=G22+.51     IF (ITRP.NE.0) GO TO 3C     NORMAL FILL      IF (ICOMP.LT.IM1) GO TO 2      CM(II1,JJ1)=G11      CM(II1,JJ2)=G122     IF (ICOMP.GE.IM2) GO TO 5      CM(II2,JJ1)=G21      CM(II2,JJ2)=G22      GO TO 5C     TRANSPOSED FILL3     IF (ICOMP.LT.IM1) GO TO 4      CM(JJ1,II1)=G11      CM(JJ2,II1)=G124     IF (ICOMP.GE.IM2) GO TO 5      CM(JJ1,II2)=G21      CM(JJ2,II2)=G225     CONTINUE      RETURN      END      SUBROUTINE CMSW (J1,J2,I1,I2,CM,CW,NCW,NROW,ITRP)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC

















































































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***C     COMPUTES MATRIX ELEMENTS FOR E ALONG WIRES DUE TO PATCH CURRENT      COMPLEX*16 CM,ZRATI,ZRATI2,T1,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC     1,EMEL,CW,FRATI      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /ANGL/ SALP(MAXSEG)      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,     &KSYMP,IFAR,IPERF      COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,     &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP     1CON(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,ICON     12), (T2Z,ITAG), (CAB,ALP), (SAB,BET)      EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y     1J,IND1), (T2ZJ,IND2)      DATA PI/3.141592654D+0/      LDP=LD+1      NEQS=N-N1+2*(M-M1)      IF (ITRP.LT.0) GO TO 13      K=0      ICGO=1C     OBSERVATION LOOP      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) GO TO 1      IPCH=ICON1(I)-10000      FSIGN=-1.1     IF (ICON2(I).LT.10000) GO TO 2      IPCH=ICON2(I)-10000      FSIGN=1.2     JL=0C     SOURCE LOOP      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)      S=BI(JS)C     GROUND LOOP      DO 12 IP=1,KSYMP      IPGND=IP      IF (IPCH.NE.J.AND.ICGO.EQ.1) GO TO 9      IF (IP.EQ.2) GO TO 9      IF (ICGO.GT.1) GO TO 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) GO TO 3      IL=NEQS+ICONX(I)      GO TO 43     IL=I-NCW      IF (I.LE.NP) IL=((IL-1)/NP)*2*MP+IL4     IF (ITRP.NE.0) GO TO 5      CW(K,IL)=CW(K,IL)+EXC*(AX(JSNO)+BX(JSNO)*PX+CX(JSNO)*PY)      GO TO 65     CW(IL,K)=CW(IL,K)+EXC*(AX(JSNO)+BX(JSNO)*PX+CX(JSNO)*PY)6     IF (ITRP.NE.0) GO TO 7      CM(K,JL-1)=EMEL(ICGO)      CM(K,JL)=EMEL(ICGO+4)      GO TO 87     CM(JL-1,K)=EMEL(ICGO)      CM(JL,K)=EMEL(ICGO+4)8     ICGO=ICGO+1      IF (ICGO.EQ.5) ICGO=1      GO TO 119     CALL UNERE (XI,YI,ZI)      IF (ITRP.NE.0) GO TO 10C     NORMAL FILL      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      GO TO 11C     TRANSPOSED FILL10    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*SALPI11    CONTINUE12    CONTINUE      RETURNC     FOR OLD SEG. CONNECTING TO OLD PATCH ON ONE END AND NEW SEG. ONC     OTHER END INTEGRATE SINGULAR COMPONENT (9) OF SURFACE CURRENT ONLY13    IF (J1.LT.I1.OR.J1.GT.I2) GO TO 16      IPCH=ICON1(J1)      IF (IPCH.LT.10000) GO TO 14      IPCH=IPCH-10000      FSIGN=-1.      GO TO 1514    IPCH=ICON2(J1)      IF (IPCH.LT.10000) GO TO 16      IPCH=IPCH-10000      FSIGN=1.15    IF (IPCH.GT.M1) GO TO 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      SUBROUTINE CMWS (J,I1,I2,CM,NR,CW,NW,ITRP)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC




















































































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     CMWS COMPUTES MATRIX ELEMENTS FOR WIRE-SURFACE INTERACTIONSC      COMPLEX*16 CM,CW,ETK,ETS,ETC,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /ANGL/ SALP(MAXSEG)      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP     1CON(10),NPCON      COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,     &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,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)      SALPJ=SALP(J)CC     OBSERVATION LOOPC      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) GO TO 1      JS=LDP-IPATCH      XI=X(JS)      YI=Y(JS)      ZI=Z(JS)      CALL HSFLD (XI,YI,ZI,0.D0)      IF (IK.EQ.0) GO TO 1      TX=T2X(JS)      TY=T2Y(JS)      TZ=T2Z(JS)      GO TO 21     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)      ETC=-(EXC*TX+EYC*TY+EZC*TZ)*SALP(JS)CC     FILL MATRIX ELEMENTS.  ELEMENT LOCATIONS DETERMINED BY CONNECTIONC     DATA.C      IF (ITRP.NE.0) GO TO 4C     NORMAL FILL      DO 3 IJ=1,JSNO      JX=JCO(IJ)3     CM(IPR,JX)=CM(IPR,JX)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)      GO TO 94     IF (ITRP.EQ.2) GO TO 6C     TRANSPOSED FILL      DO 5 IJ=1,JSNO      JX=JCO(IJ)5     CM(JX,IPR)=CM(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)      GO TO 9C     TRANSPOSED FILL - C(WS) AND D(WS)PRIME (=CW)6     DO 8 IJ=1,JSNO      JX=JCO(IJ)      IF (JX.GT.NR) GO TO 7      CM(JX,IPR)=CM(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)      GO TO 87     JX=JX-NR      CW(JX,IPR)=CW(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)8     CONTINUE9     CONTINUE      RETURN      END      SUBROUTINE CMWW (J,I1,I2,CM,NR,CW,NW,ITRP)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC
















































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     CMWW COMPUTES MATRIX ELEMENTS FOR WIRE-WIRE INTERACTIONSC      COMPLEX*16 CM,CW,ETK,ETS,ETC,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /ANGL/ SALP(MAXSEG)      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP     1CON(10),NPCON      COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,     &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND      DIMENSION CM(NR,1), CW(NW,1), CAB(1), SAB(1)      EQUIVALENCE (CAB,ALP), (SAB,BET)C     SET SOURCE SEGMENT PARAMETERS      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) GO TO 16C     DECIDE WETHER EXT. T.W. APPROX. CAN BE USED      IPR=ICON1(J)      IF (IPR) 1,6,21     IPR=-IPR      IF (-ICON1(IPR).NE.J) GO TO 7      GO TO 42     IF (IPR.NE.J) GO TO 3      IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 7      GO TO 53     IF (ICON2(IPR).NE.J) GO TO 74     XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))      IF (XI.LT.0.999999D+0) GO TO 7      IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 75     IND1=0      GO TO 86     IND1=1      GO TO 87     IND1=28     IPR=ICON2(J)      IF (IPR) 9,14,109     IPR=-IPR      IF (-ICON2(IPR).NE.J) GO TO 15      GO TO 1210    IF (IPR.NE.J) GO TO 11      IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 15      GO TO 1311    IF (ICON1(IPR).NE.J) GO TO 1512    XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))      IF (XI.LT.0.999999D+0) GO TO 15      IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 1513    IND2=0      GO TO 1614    IND2=1      GO TO 1615    IND2=216    CONTINUECC     OBSERVATION LOOPC      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      ETC=EXC*CABI+EYC*SABI+EZC*SALPICC     FILL MATRIX ELEMENTS.  ELEMENT LOCATIONS DETERMINED BY CONNECTIONC     DATA.C      IF (ITRP.NE.0) GO TO 18C     NORMAL FILL      DO 17 IJ=1,JSNO      JX=JCO(IJ)17    CM(IPR,JX)=CM(IPR,JX)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)      GO TO 2318    IF (ITRP.EQ.2) GO TO 20C     TRANSPOSED FILL      DO 19 IJ=1,JSNO      JX=JCO(IJ)19    CM(JX,IPR)=CM(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)      GO TO 23C     TRANS. FILL FOR C(WW) - TEST FOR ELEMENTS FOR D(WW)PRIME.  (=CW)20    DO 22 IJ=1,JSNO      JX=JCO(IJ)      IF (JX.GT.NR) GO TO 21      CM(JX,IPR)=CM(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)      GO TO 2221    JX=JX-NR      CW(JX,IPR)=CW(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ)22    CONTINUE23    CONTINUE      RETURN      END      SUBROUTINE CONECT (IGND)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC











































































































































































































































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     CONNECT SETS UP SEGMENT CONNECTION DATA IN ARRAYS ICON1 AND ICON2C     BY SEARCHING FOR SEGMENT ENDS THAT ARE IN CONTACT.C      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP     1CON(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) GO TO 3      WRITE(3,54)      IF (IGND.GT.0) WRITE(3,55)      IF (IPSYM.NE.2) GO TO 1      NP=2*NP      MP=2*MP1     IF (IABS(IPSYM).LE.2) GO TO 2      NP=N      MP=M2     IF (NP.GT.N) STOP      IF (NP.EQ.N.AND.MP.EQ.M) IPSYM=03     IF (N.EQ.0) GO TO 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)      SLEN=SQRT((XI2-XI1)**2+(YI2-YI1)**2+(ZI2-ZI1)**2)*SMINCC     DETERMINE CONNECTION DATA FOR END 1 OF SEGMENT.C      IF (IGND.LT.1) GO TO 5      IF (ZI1.GT.-SLEN) GO TO 4      WRITE(3,56)  I      STOP4     IF (ZI1.GT.SLEN) GO TO 5      ICON1(I)=I      Z(I)=0.      GO TO 95     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) GO TO 6      ICON1(I)=-IC      GO TO 86     SEP=ABS(XI1-X2(IC))+ABS(YI1-Y2(IC))+ABS(ZI1-Z2(IC))      IF (SEP.GT.SLEN) GO TO 7      ICON1(I)=IC      GO TO 87     CONTINUE      IF (I.LT.N2.AND.ICON1(I).GT.10000) GO TO 8      ICON1(I)=0CC     DETERMINE CONNECTION DATA FOR END 2 OF SEGMENT.C8     IF (IGND.LT.1) GO TO 129     IF (ZI2.GT.-SLEN) GO TO 10      WRITE(3,56)  I      STOP10    IF (ZI2.GT.SLEN) GO TO 12      IF (ICON1(I).NE.I) GO TO 11      WRITE(3,57)  I      STOP11    ICON2(I)=I      Z2(I)=0.      GO TO 1512    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) GO TO 13      ICON2(I)=IC      GO TO 1513    SEP=ABS(XI2-X2(IC))+ABS(YI2-Y2(IC))+ABS(ZI2-Z2(IC))      IF (SEP.GT.SLEN) GO TO 14      ICON2(I)=-IC      GO TO 1514    CONTINUE      IF (I.LT.N2.AND.ICON2(I).GT.10000) GO TO 15      ICON2(I)=015    CONTINUE      IF (M.EQ.0) GO TO 26C     FIND WIRE-SURFACE CONNECTIONS FOR NEW PATCHES      IX=LD+1-M1      I=M216    IF (I.GT.M) GO TO 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)      SLEN=(ABS(XI2-XI1)+ABS(YI2-YI1)+ABS(ZI2-ZI1))*SMINC     FOR FIRST END OF SEGMENT      SEP=ABS(XI1-XS)+ABS(YI1-YS)+ABS(ZI1-ZS)      IF (SEP.GT.SLEN) GO TO 17C     CONNECTION - DIVIDE PATCH INTO 4 PATCHES AT PRESENT ARRAY LOC.      ICON1(ISEG)=10000+I      IC=0      CALL SUBPH (I,IC,XI1,YI1,ZI1,XI2,YI2,ZI2,XA,YA,ZA,XS,YS,ZS)      GO TO 1917    SEP=ABS(XI2-XS)+ABS(YI2-YS)+ABS(ZI2-ZS)      IF (SEP.GT.SLEN) GO TO 18      ICON2(ISEG)=10000+I      IC=0      CALL SUBPH (I,IC,XI1,YI1,ZI1,XI2,YI2,ZI2,XA,YA,ZA,XS,YS,ZS)      GO TO 1918    CONTINUE19    I=I+1      GO TO 16C     REPEAT SEARCH FOR NEW SEGMENTS CONNECTED TO NGF PATCHES.20    IF (M1.EQ.0.OR.N2.GT.N) GO TO 26      IX=LD+1      I=121    IF (I.GT.M1) GO TO 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) GO TO 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)      GO TO 2422    SEP=ABS(XI2-XS)+ABS(YI2-YS)+ABS(ZI2-ZS)      IF (SEP.GT.SLEN) GO TO 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)      GO TO 2423    CONTINUE24    I=I+1      GO TO 2125    IF (NPCON.LE.NPMAX) GO TO 26      WRITE(3,62)  NPMAX      STOP26    WRITE(3,58)  N,NP,IPSYM      IF (M.GT.0) WRITE(3,61)  M,MP      ISEG=(N+M)/(NP+MP)      IF (ISEG.EQ.1) GO TO 30      IF (IPSYM) 28,27,2927    STOP28    WRITE(3,59) ISEG      GO TO 3029    IC=ISEG/2      IF (ISEG.EQ.8) IC=3      WRITE(3,60)  IC30    IF (N.EQ.0) GO TO 48      WRITE(3,50)      ISEG=0C     ADJUST CONNECTED SEG. ENDS TO EXACTLY COINCIDE.  PRINT JUNCTIONSC     OF 3 OR MORE SEG.  ALSO FIND OLD SEG. CONNECTING TO NEW SEG.      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) GO TO 43      IF (IX.EQ.J) GO TO 43      IF (IX.GT.10000) GO TO 43      NSFLG=032    IF (IX) 33,49,3433    IX=-IX      GO TO 3534    JEND=-JEND35    IF (IX.EQ.J) GO TO 37      IF (IX.LT.J) GO TO 43      IC=IC+1      IF (IC.GT.JMAX) GO TO 49      JCO(IC)=IX*JEND      IF (IX.GT.N1) NSFLG=1      IF (JEND.EQ.1) GO TO 36      XA=XA+X(IX)      YA=YA+Y(IX)      ZA=ZA+Z(IX)      IX=ICON1(IX)      GO TO 3236    XA=XA+X2(IX)      YA=YA+Y2(IX)      ZA=ZA+Z2(IX)      IX=ICON2(IX)      GO TO 3237    SEP=IC      XA=XA/SEP      YA=YA/SEP      ZA=ZA/SEP      DO 39 I=1,IC      IX=JCO(I)      IF (IX.GT.0) GO TO 38      IX=-IX      X(IX)=XA      Y(IX)=YA      Z(IX)=ZA      GO TO 3938    X2(IX)=XA      Y2(IX)=YA      Z2(IX)=ZA39    CONTINUE      IF (N1.EQ.0) GO TO 42      IF (NSFLG.EQ.0) GO TO 42      DO 41 I=1,IC      IX=IABS(JCO(I))      IF (IX.GT.N1) GO TO 41      IF (ICONX(IX).NE.0) GO TO 41      NSCON=NSCON+1      IF (NSCON.LE.NSMAX) GO TO 40      WRITE(3,62)  NSMAX      STOP40    ISCON(NSCON)=IX      ICONX(IX)=NSCON41    CONTINUE42    IF (IC.LT.3) GO TO 43      ISEG=ISEG+1      WRITE(3,51) ISEG,(JCO(I),I=1,IC)43    IF (IEND.EQ.1) GO TO 44      IEND=1      JEND=1      IX=ICON2(J)      IC=1      JCO(1)=J      XA=X2(J)      YA=Y2(J)      ZA=Z2(J)      GO TO 3144    CONTINUE      IF (ISEG.EQ.0) WRITE(3,52)      IF (N1.EQ.0.OR.M1.EQ.M) GO TO 48C     FIND OLD SEGMENTS THAT CONNECT TO NEW PATCHES      DO 47 J=1,N1      IX=ICON1(J)      IF (IX.LT.10000) GO TO 45      IX=IX-10000      IF (IX.GT.M1) GO TO 4645    IX=ICON2(J)      IF (IX.LT.10000) GO TO 47      IX=IX-10000      IF (IX.LT.M2) GO TO 4746    IF (ICONX(J).NE.0) GO TO 47      NSCON=NSCON+1      ISCON(NSCON)=J      ICONX(J)=NSCON47    CONTINUE48    CONTINUE      RETURN49    WRITE(3,53)  IX      STOPC50    FORMAT (//,9X,27H- MULTIPLE WIRE JUNCTIONS -,/,1X,8HJUNCTION,4X,36     1HSEGMENTS  (- FOR END 1, + FOR END 2))51    FORMAT (1X,I5,5X,20I5,/,(11X,20I5))52    FORMAT (2X,4HNONE)53    FORMAT (47H CONNECT - SEGMENT CONNECTION ERROR FOR SEGMENT,I5)54    FORMAT (/,3X,23HGROUND PLANE SPECIFIED.)55    FORMAT (/,3X,46HWHERE WIRE ENDS TOUCH GROUND, CURRENT WILL BE ,38H     1INTERPOLATED TO IMAGE IN GROUND PLANE.,/)56    FORMAT (30H GEOMETRY DATA ERROR-- SEGMENT,I5,21H EXTENDS BELOW GRO     1UND)57    FORMAT (29H GEOMETRY DATA ERROR--SEGMENT,I5,16H LIES IN GROUND ,6H     1PLANE.)58    FORMAT (/,3X,20HTOTAL SEGMENTS USED=,I5,5X,12HNO. SEG. IN ,17HA SY     1MMETRIC CELL=,I5,5X,14HSYMMETRY FLAG=,I3)59    FORMAT (14H STRUCTURE HAS,I4,25H FOLD ROTATIONAL SYMMETRY,/)60    FORMAT (14H STRUCTURE HAS,I2,19H PLANES OF SYMMETRY,/)61    FORMAT (3X,19HTOTAL PATCHES USED=,I5,6X,32HNO. PATCHES IN A SYMMET     1RIC CELL=,I5)62    FORMAT (' ERROR - NO. NEW SEGMENTS CONNECTED TO N.G.F. SEGMENTS 
',     &'OR PATCHES EXCEEDS LIMIT OF















































































',I5)      END      SUBROUTINE COUPLE (CUR,WLAM)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***CC     COUPLE COMPUTES THE MAXIMUM COUPLING BETWEEN PAIRS OF SEGMENTS.C      COMPLEX*16 Y11A,Y12A,CUR,Y11,Y12,Y22,YL,YIN,ZL,ZIN,RHO,VQD,VSANT     1,VQDS      COMMON/YPARM/Y11A(5),Y12A(20),NCOUP,ICOUP,NCTAG(5),NCSEG(5)      COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS(     130),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) GO TO 1      K=ISEGNO(NCTAG(I),NCSEG(I))      L1=L1+1      Y12A(L1)=CUR(K)*WLAM/ZIN1     CONTINUE      IF (ICOUP.LT.NCOUP) RETURN      WRITE(3,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.*DREAL(Y11)*DREAL(Y22)-DREAL(YIN))      IF (C.LT.0..OR.C.GT.1.) GO TO 4      IF (C.LT..01) GO TO 2      GMAX=(1.-SQRT(1.-C*C))/C      GO TO 32     GMAX=.5*(C+.25*C*C*C)3     RHO=GMAX*DCONJG(YIN)/DBC      YL=((1.-RHO)/(1.+RHO)+1.)*DREAL(Y22)-Y22      ZL=1./YL      YIN=Y11-YIN/(Y22+YL)      ZIN=1./YIN      DBC=DB10(GMAX)      WRITE(3,7)  ITT1,ITS1,ISG1,ITT2,ITS2,ISG2,DBC,ZL,ZIN      GO TO 54     WRITE(3,8)  ITT1,ITS1,ISG1,ITT2,ITS2,ISG2,C5     CONTINUE      RETURNC6     FORMAT (///,36X,26H- - - ISOLATION DATA - - -,//,6X,24H- - COUPLIN     1G BETWEEN - -,8X,7HMAXIMUM,15X,32H- - - FOR MAXIMUM COUPLING - - -     2,/,12X,4HSEG.,14X,4HSEG.,3X,8HCOUPLING,4X,25HLOAD IMPEDANCE (2ND S     3EG.),7X,15HINPUT IMPEDANCE,/,2X,8HTAG/SEG.,3X,3HNO.,4X,8HTAG/SEG.,     43X,3HNO.,6X,4H(DB),8X,4HREAL,9X,5HIMAG.,9X,4HREAL,9X,5HIMAG.)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),45H**ERROR** COUPLING IS NOT BETWE     1EN 0 AND 1. (=,1P,E12.5,1H))      END      SUBROUTINE DATAGNC ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC





















'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     DATAGN IS THE MAIN ROUTINE FOR INPUT OF GEOMETRY DATA.CC***      CHARACTER*2 GM,ATSTC***      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /ANGL/ SALP(MAXSEG)C***      COMMON /PLOT/ IPLP1,IPLP2,IPLP3,IPLP4C***      DIMENSION X2(1), Y2(1), Z2(1), T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y     1(1), T2Z(1), ATST(13), IFX(2), IFY(2), IFZ(2), CAB(1), SAB(1), IPT     2(4)      EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON     12), (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
',     1'GC','GH



















































































'/C***      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      IPHD=0CC     READ GEOMETRY DATA CARD AND BRANCH TO SECTION FOR OPERATIONC     REQUESTEDC1     CALL READGM(2,GM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD)      IF (N+M.GT.LD) GO TO 37      IF (GM.EQ.ATST(9)) GO TO 27      IF (IPHD.EQ.1) GO TO 2      WRITE(3,40)      WRITE(3,41)      IPHD=12     IF (GM.EQ.ATST(11)) GO TO 10      ISCT=0      IF (GM.EQ.ATST(1)) GO TO 3      IF (GM.EQ.ATST(2)) GO TO 18      IF (GM.EQ.ATST(3)) GO TO 19      IF (GM.EQ.ATST(4)) GO TO 21      IF (GM.EQ.ATST(7)) GO TO 9      IF (GM.EQ.ATST(8)) GO TO 13      IF (GM.EQ.ATST(5)) GO TO 29      IF (GM.EQ.ATST(6)) GO TO 26      IF (GM.EQ.ATST(10)) GO TO 8C***      IF (GM.EQ.ATST(13)) GO TO 123C***      GO TO 36CC     GENERATE SEGMENT DATA FOR STRAIGHT WIRE.C3     NWIRE=NWIRE+1      I1=N+1      I2=N+NS      WRITE(3,43)  NWIRE,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,NS,I1,I2,ITG      IF (RAD.EQ.0) GO TO 4      XS1=1.      YS1=1.      GO TO 74     CALL READGM(2,GM,IX,IY,XS1,YS1,ZS1,DUMMY,DUMMY,DUMMY,DUMMY)C***      IF (GM.EQ.ATST(12)) GO TO 65     WRITE(3,48)      STOP6     WRITE(3,61)  XS1,YS1,ZS1      IF (YS1.EQ.0.OR.ZS1.EQ.0) GO TO 5      RAD=YS1      YS1=(ZS1/YS1)**(1./(NS-1.))7     CALL WIRE (XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,XS1,YS1,NS,ITG)      GO TO 1CC     GENERATE SEGMENT DATA FOR WIRE ARCC8     NWIRE=NWIRE+1      I1=N+1      I2=N+NS      WRITE(3,38)  NWIRE,XW1,YW1,ZW1,XW2,NS,I1,I2,ITG      CALL ARC (ITG,NS,XW1,YW1,ZW1,XW2)      GO TO 1C***CC     GENERATE HELIXC123   NWIRE=NWIRE+1      I1=N+1      I2=N+NS      WRITE(3,124) XW1,YW1,NWIRE,ZW1,XW2,YW2,ZW2,RAD,NS,I1,I2,ITG      CALL HELIX(XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,NS,ITG)      GO TO 1C124   FORMAT(5X,'HELIX STRUCTURE-   AXIAL SPACING BETWEEN TURNS =
',F8.3,     1' TOTAL AXIAL LENGTH =',F8.3/1X,I5,2X,'RADIUS OF HELIX =















































































































',4(2X,     2F8.3),7X,F11.5,I8,4X,I5,1X,I5,3X,I5)C***CC     GENERATE SINGLE NEW PATCHC9     I1=M+1      NS=NS+1      IF (ITG.NE.0) GO TO 17      WRITE(3,51)  I1,IPT(NS),XW1,YW1,ZW1,XW2,YW2,ZW2      IF (NS.EQ.2.OR.NS.EQ.4) ISCT=1      IF (NS.GT.1) GO TO 14      XW2=XW2*TA      YW2=YW2*TA      GO TO 1610    IF (ISCT.EQ.0) GO TO 17      I1=M+1      NS=NS+1      IF (ITG.NE.0) GO TO 17      IF (NS.NE.2.AND.NS.NE.4) GO TO 17      XS1=X4      YS1=Y4      ZS1=Z4      XS2=X3      YS2=Y3      ZS2=Z3      X3=XW1      Y3=YW1      Z3=ZW1      IF (NS.NE.4) GO TO 11      X4=XW2      Y4=YW2      Z4=ZW211    XW1=XS1      YW1=YS1      ZW1=ZS1      XW2=XS2      YW2=YS2      ZW2=ZS2      IF (NS.EQ.4) GO TO 12      X4=XW1+X3-XW2      Y4=YW1+Y3-YW2      Z4=ZW1+Z3-ZW212    WRITE(3,51)  I1,IPT(NS),XW1,YW1,ZW1,XW2,YW2,ZW2      WRITE(3,39)  X3,Y3,Z3,X4,Y4,Z4      GO TO 16CC     GENERATE MULTIPLE-PATCH SURFACEC13    I1=M+1      WRITE(3,59)  I1,IPT(2),XW1,YW1,ZW1,XW2,YW2,ZW2,ITG,NS      IF (ITG.LT.1.OR.NS.LT.1) GO TO 1714    CALL READGM(2,GM,IX,IY,X3,Y3,Z3,X4,Y4,Z4,DUMMY)      IF (NS.NE.2.AND.ITG.LT.1) GO TO 15      X4=XW1+X3-XW2      Y4=YW1+Y3-YW2      Z4=ZW1+Z3-ZW215    WRITE(3,39)  X3,Y3,Z3,X4,Y4,Z4      IF (GM.NE.ATST(11)) GO TO 1716    CALL PATCH (ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,X3,Y3,Z3,X4,Y4,Z4)      GO TO 117    WRITE(3,60)      STOPCC     REFLECT STRUCTURE ALONG X,Y, OR Z AXES OR ROTATE TO FORM CYLINDER.C18    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(3,44)  IFX(IX+1),IFY(IY+1),IFZ(IZ+1),ITG      GO TO 2019    WRITE(3,45)  NS,ITG      IX=-120    CALL REFLC (IX,IY,IZ,ITG,NS)      GO TO 1CC     SCALE STRUCTURE DIMENSIONS BY FACTOR XW1.C21    IF (N.LT.N2) GO TO 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)*XW122    BI(I)=BI(I)*XW123    IF (M.LT.M2) GO TO 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)*XW124    BI(I)=BI(I)*YW125    WRITE(3,46)  XW1      GO TO 1CC     MOVE STRUCTURE OR REPRODUCE ORIGINAL STRUCTURE IN NEW POSITIONS.C26    WRITE(3,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)      GO TO 1CC     READ NUMERICAL GREEN'S FUNCTION TAPE
C
27    IF (N+M.EQ.0) GO TO 28
      WRITE(3,52)
      STOP
28    CALL GFIL (ITG)
      NPSAV=NP
      MPSAV=MP
      IPSAV=IPSYM
      GO TO 1
C
C     TERMINATE STRUCTURE GEOMETRY INPUT.
C
C***
29    IF(NS.EQ.0) GO TO 290
      IPLP1=1
      IPLP2=1
290   IX=N1+M1
C***
      IF (IX.EQ.0) GO TO 30
      NP=N
      MP=M
      IPSYM=0
30    CALL CONECT (ITG)
      IF (IX.EQ.0) GO TO 31
      NP=NPSAV
      MP=MPSAV
      IPSYM=IPSAV
31    IF (N+M.GT.LD) GO TO 37
      IF (N.EQ.0) GO TO 33
      WRITE(3,53)
      WRITE(3,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
      WRITE(3,55) I,X(I),Y(I),Z(I),SI(I),XW2,YW2,BI(I),ICON1(I),I,
     1ICON2(I),ITAG(I)
C***
      IF(IPLP1.NE.1) GO TO 320
      WRITE(8,*)X(I),Y(I),Z(I),SI(I),XW2,YW2,BI(I),ICON1(I),I,ICON2(I)
320   CONTINUE
C***
      IF (SI(I).GT.1.D-20.AND.BI(I).GT.0.) GO TO 32
      WRITE(3,56)
      STOP
32    CONTINUE
33    IF (M.EQ.0) GO TO 35
      WRITE(3,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(3,58) I,X(J),Y(J),Z(J),XW1,YW1,ZW1,BI(J),T1X(J),T1Y(J),
     1T1Z(J),T2X(J),T2Y(J),T2Z(J)
34    CONTINUE
35    RETURN
36    WRITE(3,48)
      WRITE(3,49)  GM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD
      STOP
37    WRITE(3,50)
      STOP
C
38    FORMAT (1X,I5,2X,12HARC RADIUS =,F9.5,2X,4HFROM,F8.3,3H TO,F8.3,8H
     1 DEGREES,11X,F11.5,2X,I5,4X,I5,1X,I5,3X,I5)
39    FORMAT (6X,3F11.5,1X,3F11.5)
40    FORMAT (////,33X,35H- - - STRUCTURE SPECIFICATION - - -,//,37X,28H
     1COORDINATES MUST BE INPUT IN,/,37X,29HMETERS OR BE SCALED TO METER
     2S,/,37X,31HBEFORE STRUCTURE INPUT IS ENDED,//)
41    FORMAT (2X,4HWIRE,79X,6HNO. OF,4X,5HFIRST,2X,4HLAST,5X,3HTAG,/,2X,
     13HNO.,8X,2HX1,9X,2HY1,9X,2HZ1,10X,2HX2,9X,2HY2,9X,2HZ2,6X,6HRADIUS
     2,3X,4HSEG.,5X,4HSEG.,3X,4HSEG.,5X,3HNO.)
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,34HSTRUCTURE REFLECTED ALONG THE AXES,3(1X,A1),22H.  TA
     1GS INCREMENTED BY,I5)
45    FORMAT (6X,30HSTRUCTURE ROTATED ABOUT Z-AXIS,I3,30H TIMES.  LABELS
     1 INCREMENTED BY,I5)
46    FORMAT (6X,26HSTRUCTURE SCALED BY FACTOR,F10.5)
47    FORMAT (6X,49HTHE STRUCTURE HAS BEEN MOVED, MOVE DATA CARD IS -/6X
     1,I3,I5,7F10.5)
48    FORMAT (25H GEOMETRY DATA CARD ERROR)
49    FORMAT (1X,A2,I3,I5,7F10.5)
50    FORMAT (69H NUMBER OF WIRE SEGMENTS AND SURFACE PATCHES EXCEEDS DI
     1MENSION LIMIT.)
51    FORMAT (1X,I5,A1,F10.5,2F11.5,1X,3F11.5)
52    FORMAT (44H ERROR - GF MUST BE FIRST GEOMETRY DATA CARD)
53    FORMAT (////33X,33H- - - - SEGMENTATION DATA - - - -,//,40X,21HCOO
     1RDINATES IN METERS,//,25X,50HI+ AND I- INDICATE THE SEGMENTS BEFOR
     2E AND AFTER I,//)
54    FORMAT (2X,4HSEG.,3X,26HCOORDINATES OF SEG. CENTER,5X,4HSEG.,5X,18
     1HORIENTATION ANGLES,4X,4HWIRE,4X,15HCONNECTION DATA,3X,3HTAG,/,2X,
     23HNO.,7X,1HX,9X,1HY,9X,1HZ,7X,6HLENGTH,5X,5HALPHA,5X,4HBETA,6X,6HR
     3ADIUS,4X,2HI-,3X,1HI,4X,2HI+,4X,3HNO.)
55    FORMAT (1X,I5,4F10.5,1X,3F10.5,1X,3I5,2X,I5)
56    FORMAT (19H SEGMENT DATA ERROR)
57    FORMAT (////,44X,30H- - - SURFACE PATCH DATA - - -,//,49X,21HCOORD
     1INATES IN METERS,//,1X,5HPATCH,5X,22HCOORD. OF PATCH CENTER,7X,18H
     2UNIT NORMAL VECTOR,6X,5HPATCH,12X,34HCOMPONENTS OF UNIT TANGENT VE
     3CTORS,/,2X,3HNO.,6X,1HX,9X,1HY,9X,1HZ,9X,1HX,7X,1HY,7X,1HZ,7X,4HAR
     4EA,7X,2HX1,6X,2HY1,6X,2HZ1,7X,2HX2,6X,2HY2,6X,2HZ2)
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,9HSURFACE -,I4,3H BY,I3
     1,8H PATCHES)
60    FORMAT (17H PATCH DATA ERROR)
61    FORMAT (9X,43HABOVE WIRE IS TAPERED.  SEG. LENGTH RATIO =,F9.5,/,3
     13X,11HRADIUS FROM,F9.5,3H TO,F9.5)
      END
      FUNCTION DB10 (X)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     FUNCTION DB-- RETURNS DB FOR MAGNITUDE (FIELD) OR MAG**2 (POWER) I
C
      F=10.
      GO TO 1
      ENTRY DB20(X)
      F=20.
1     IF (X.LT.1.D-20) GO TO 2
      DB10=F*LOG10(X)
      RETURN
2     DB10=-999.99
      RETURN
      END
      SUBROUTINE EFLD (XI,YI,ZI,AI,IJ)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     COMPUTE NEAR E FIELDS OF A SEGMENT WITH SINE, COSINE, AND
C     CONSTANT CURRENTS.  GROUND EFFECT INCLUDED.
C
      COMPLEX*16 TXK,TYK,TZK,TXS,TYS,TZS,TXC,TYC,TZC,EXK,EYK,EZK,EXS,EYS
     1,EZS,EXC,EYC,EZC,EPX,EPY,ZRATI,REFS,REFPS,ZRSIN,ZRATX,T1,ZSCRN
     2,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,IND1,INDD1,IND2,INDD2,IEXK,IPGND
      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,
     &KSYMP,IFAR,IPERF
      COMMON /INCOM/ XO,YO,ZO,SN,XSN,YSN,ISNOR
      DIMENSION EGND(9)
      EQUIVALENCE (EGND(1),TXK), (EGND(2),TYK), (EGND(3),TZK), (EGND(4),
     1TXS), (EGND(5),TYS), (EGND(6),TZS), (EGND(7),TXC), (EGND(8),TYC),
     2(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) GO TO 1
      RHOX=0.
      RHOY=0.
      RHOZ=0.
      GO TO 2
1     RHOX=RHOX/RH
      RHOY=RHOY/RH
      RHOZ=RHOZ/RH
2     R=SQRT(ZP*ZP+RH*RH)
      IF (R.LT.RKH) GO TO 3
C
C     LUMPED CURRENT ELEMENT APPROX. FOR LARGE SEPARATIONS
C
      RMAG=TP*R
      CTH=ZP/R
      PX=RH/R
      TXK=DCMPLX(COS(RMAG),-SIN(RMAG))
      PY=TP*R*R
      TYK=ETA*CTH*TXK*DCMPLX(1.D+0,-1.D+0/RMAG)/PY
      TZK=ETA*PX*TXK*DCMPLX(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.)
      GO TO 6
3     IF (IEXK.EQ.1) GO TO 4
C
C     EKSC FOR THIN WIRE APPROX. OR EKSCX FOR EXTENDED T.W. APPROX.
C
      CALL EKSC (S,ZP,RH,TP,IJX,TEZS,TERS,TEZC,TERC,TEZK,TERK)
      GO TO 5
4     CALL EKSCX (B,S,ZP,RH,TP,IJX,IND1,IND2,TEZS,TERS,TEZC,TERC,TEZK,TE
     1RK)
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) GO TO 11
      IF (IPERF.GT.0) GO TO 10
      ZRATX=ZRATI
      RMAG=R
      XYMAG=SQRT(XIJ*XIJ+YIJ*YIJ)
C
C     SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.
C
      IF (NRADL.EQ.0) GO TO 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) GO TO 7
      ZSCRN=T1*RHOSPC*LOG(RHOSPC/T2)
      ZRATX=(ZSCRN*ZRATI)/(ETA*ZRATI+ZSCRN)
7     IF (XYMAG.GT.1.D-6) GO TO 8
C
C     CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.
C
      PX=0.
      PY=0.
      CTH=1.
      ZRSIN=(1.,0.)
      GO TO 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
      GO TO 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) GO TO 13
      RETURN
C
C     FIELD DUE TO GROUND USING SOMMERFELD/NORTON
C
13    SN=SQRT(CABJ*CABJ+SABJ*SABJ)
      IF (SN.LT.1.D-5) GO TO 14
      XSN=CABJ/SN
      YSN=SABJ/SN
      GO TO 15
14    SN=0.
      XSN=1.
      YSN=0.
C
C     DISPLACE OBSERVATION POINT FOR THIN WIRE APPROXIMATION
C
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) GO TO 16
      XO=XI-AI*YSN
      YO=YI+AI*XSN
      ZO=ZI
      GO TO 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
      IF (R.GT..95) GO TO 18
C
C     FIELD FROM INTERPOLATION IS INTEGRATED OVER SEGMENT
C
      ISNOR=1
      DMIN=EXK*DCONJG(EXK)+EYK*DCONJG(EYK)+EZK*DCONJG(EZK)
      DMIN=.01*SQRT(DMIN)
      SHAF=.5*S
      CALL ROM2 (-SHAF,SHAF,EGND,DMIN)
      GO TO 19
C
C     NORTON FIELD EQUATIONS AND LUMPED CURRENT ELEMENT APPROXIMATION
C
18    ISNOR=2
      CALL SFLDS (0.D0,EGND)
      GO TO 22
19    ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR
      RH=R-ZP*ZP
      IF (RH.GT.1.D-10) GO TO 20
      DMIN=0.
      GO TO 21
20    DMIN=SQRT(RH/(RH+AI*AI))
21    IF (DMIN.GT..95) GO TO 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
      SUBROUTINE EKSC (S,Z,RH,XK,IJ,EZS,ERS,EZC,ERC,EZK,ERK)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C     COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
C     THIN WIRE APPROXIMATION.
      COMPLEX*16 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*DCMPLX(CINT,-SINT))
      GZP1=GZP1*Z1
      GZP2=GZP2*Z2
      IF (RH.LT.1.D-10) GO TO 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
      SUBROUTINE EKSCX (BX,S,Z,RHX,XK,IJ,INX1,INX2,EZS,ERS,EZC,ERC,EZK,E
     1RK)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C     COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
C     EXTENDED THIN WIRE APPROXIMATION.
      COMPLEX*16 CON,GZ1,GZ2,GZP1,GZP2,GR1,GR2,GRP1,GRP2,EZS,EZC,ERS,ERC
     1,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) GO TO 1
      RH=RHX
      B=BX
      IRA=0
      GO TO 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) GO TO 3
      CALL GXX (Z1,RH,B,A2,XK,IRA,GZ1,GZP1,GR1,GRP1,GRK1,GZZ1)
      GO TO 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) GO TO 5
      CALL GXX (Z2,RH,B,A2,XK,IRA,GZ2,GZP2,GR2,GRP2,GRK2,GZZ2)
      GO TO 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)*DCMPLX(CINT,-SINT)-BK2*(GZZ2-
     1GZZ1))
      RETURN
      END
      SUBROUTINE ERROR
C ***
C     GET REASON FOR FILE ERROR (VAX ONLY).  ERROR SHOULD BE REDUCED TO 
C     "RETURN END" FOR MACINTOSH.
C
C      IMPLICIT INTEGER (A-Z)
C      CHARACTER MSG*80
C      CALL ERRSNS(FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL)
C      CALL SYS$GETMSG(%VAL(RMSSTS),MSGLEN,MSG,,,)
C      CALL STR$UPCASE(MSG,MSG)
C      IND=INDEX(MSG,',')
C      TYPE 1,MSG(IND+2:MSGLEN)
C1     FORMAT(//,'  ****  ERROR  ****   ',//,5X,A,//)
      RETURN
      END
      SUBROUTINE ETMNS (P1,P2,P3,P4,P5,P6,IPR,E)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
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
      COMPLEX*16 E,CX,CY,CZ,VSANT,ER,ET,EZH,ERH,VQD,VQDS,ZRATI
     1,ZRATI2,RRV,RRH,T1,TT1,TT2,FRATI
      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM
      COMMON /ANGL/ SALP(MAXSEG)
      COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS(
     130),NVQD,NSANT,NQDS
      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,
     &KSYMP,IFAR,IPERF
      DIMENSION CAB(1), SAB(1), E(2*MAXSEG)
      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,ICON
     12), (T2Z,ITAG)
      DATA TP/6.283185308D+0/,RETA/2.654420938D-3/
      NEQ=N+2*M
      NQDS=0
      IF (IPR.GT.0.AND.IPR.NE.5) GO TO 5
C
C     APPLIED FIELD OF VOLTAGE SOURCES FOR TRANSMITTING CASE
C
      DO 1 I=1,NEQ
1     E(I)=(0.,0.)
      IF (NSANT.EQ.0) GO TO 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
5     IF (IPR.GT.3) GO TO 19
C
C     INCIDENT PLANE WAVE, LINEARLY POLARIZED.
C
      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) GO TO 7
      IF (IPERF.EQ.1) GO TO 6
      RRV=SQRT(1.-ZRATI*ZRATI*STH*STH)
      RRH=ZRATI*CTH
      RRH=(RRH-RRV)/(RRH+RRV)
      RRV=ZRATI*RRV
      RRV=-(CTH-RRV)/(CTH+RRV)
      GO TO 7
6     RRV=-(1.,0.)
      RRH=-(1.,0.)
7     IF (IPR.GT.1) GO TO 13
      IF (N.EQ.0) GO TO 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))*DCMPLX(COS(ARG),SIN(ARG))
      IF (KSYMP.EQ.1) GO TO 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))*DCMPLX(COS(ARG),
     1SIN(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=DCMPLX(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=DCMPLX(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
      RETURN
C
C     INCIDENT PLANE WAVE, ELLIPTIC POLARIZATION.
C
13    TT1=-(0.,1.)*P6
      IF (IPR.EQ.3) TT1=-TT1
      IF (N.EQ.0) GO TO 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))*DCMPLX(COS(ARG),SIN(ARG))
      IF (KSYMP.EQ.1) GO TO 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))*DCMPLX(COS(ARG),
     1SIN(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=DCMPLX(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=DCMPLX(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
      RETURN
C
C     INCIDENT FIELD OF AN ELEMENTARY CURRENT SOURCE.
C
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) GO TO 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) GO TO 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) GO TO 21
      QX=QX/ARG
      QY=QY/ARG
      QZ=QZ/ARG
      GO TO 22
21    QX=1.
      QY=0.
      QZ=0.
22    ARG=-TP*R
      TT1=DCMPLX(COS(ARG),SIN(ARG))
      IF (I.GT.N) GO TO 23
      TT2=DCMPLX(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))
      GO TO 24
23    PX=WY*QZ-WZ*QY
      PY=WZ*QX-WX*QZ
      PZ=WX*QY-WY*QX
      TT2=DSH*TT1*DCMPLX(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
      SUBROUTINE FACGF (A,B,C,D,BX,IP,IX,NP,N1,MP,M1,N1C,N2C)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C     FACGF COMPUTES AND FACTORS D-C(INV(A)B).
      COMPLEX*16 A,B,C,D,BX,SUM
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
     1CASX,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(1)
      IF (N2C.EQ.0) RETURN
      IBFL=14
      IF (ICASX.LT.3) GO TO 1
C     CONVERT B FROM BLOCKS OF ROWS ON T14 TO BLOCKS OF COL. ON T16
      CALL REBLK (B,C,N1C,NPBX,N2C)
      IBFL=16
1     NPB=NPBL
      IF (ICASX.EQ.2) REWIND 14
C     COMPUTE INV(A)B AND WRITE ON TAPE14
      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) GO TO 3
      REWIND 11
      REWIND 12
      REWIND 15
      REWIND IBFL
3     NPC=NPBL
C     COMPUTE D-C(INV(A)B) AND WRITE ON TAPE11
      DO 8 IC=1,NBBL
      IF (IC.EQ.NBBL) NPC=NLBL
      IF (ICASX.EQ.1) GO TO 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) GO TO 9
      REWIND 11
      REWIND 12
      REWIND 14
      REWIND 15
9     N1CP=N1C+1
C     FACTOR D-C(INV(A)B)
      IF (ICASX.GT.1) GO TO 10
      CALL FACTR (N2C,D,IP(N1CP),N2C)
      GO TO 13
10    IF (ICASX.EQ.4) GO TO 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
      GO TO 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
      SUBROUTINE FACIO (A,NROW,NOP,IP,IU1,IU2,IU3,IU4)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     FACIO CONTROLS I/O FOR OUT-OF-CORE FACTORIZATION
C
      COMPLEX*16 A
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
     1CASX,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 SECOND (T1)
      CALL LFACTR (A,NROW,IXBLK1,IXBLK2,IP(KA))
      CALL SECOND (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) GO TO 2
      IFILE3=IU4
      IFILE4=IU3
2     CONTINUE
3     CONTINUE
      REWIND IU1
      REWIND IU2
      REWIND IU3
      REWIND IU4
      WRITE(3,4)  TIME
      RETURN
C
4     FORMAT (35H CP TIME TAKEN FOR FACTORIZATION = ,1P,E12.5)
      END
      SUBROUTINE FACTR (N,A,IP,NDIM)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
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
      COMPLEX*16 A,D,ARJ
      DIMENSION A(NDIM,NDIM), IP(NDIM)
      COMMON /SCRATM/ D(2*MAXSEG)
      INTEGER R,RM1,RP1,PJ,PR
C
C     Un-transpose the matrix for Gauss elimination
C
      DO 12 I=2,N
         DO 11 J=1,I-1
            ARJ=A(I,J)
            A(I,J)=A(J,I)
            A(J,I)=ARJ
11       CONTINUE
12    CONTINUE
      IFLG=0
      DO 9 R=1,N
C
C     STEP 1
C
      DO 1 K=1,N
      D(K)=A(K,R)
1     CONTINUE
C
C     STEPS 2 AND 3
C
      RM1=R-1
      IF (RM1.LT.1) GO TO 4
      DO 3 J=1,RM1
      PJ=IP(J)
      ARJ=D(PJ)
      A(J,R)=ARJ
      D(PJ)=D(J)
      JP1=J+1
      DO 2 I=JP1,N
      D(I)=D(I)-A(I,J)*ARJ
2     CONTINUE
3     CONTINUE
4     CONTINUE
C
C     STEP 4
C
      DMAX=DREAL(D(R)*DCONJG(D(R)))
      IP(R)=R
      RP1=R+1
      IF (RP1.GT.N) GO TO 6
      DO 5 I=RP1,N
      ELMAG=DREAL(D(I)*DCONJG(D(I)))
      IF (ELMAG.LT.DMAX) GO TO 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)
      D(PR)=D(R)
C
C     STEP 5
C
      IF (RP1.GT.N) GO TO 8
      ARJ=1./A(R,R)
      DO 7 I=RP1,N
      A(I,R)=D(I)*ARJ
7     CONTINUE
8     CONTINUE
      IF (IFLG.EQ.0) GO TO 9
      WRITE(3,10)  R,DMAX
      IFLG=0
9     CONTINUE
      RETURN
C
10    FORMAT (1H ,6HPIVOT(,I3,2H)=,1P,E16.8)
      END
      SUBROUTINE FACTRS (NP,NROW,A,IP,IX,IU1,IU2,IU3,IU4)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
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
      COMPLEX*16 A
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
     1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
      DIMENSION A(1), IP(NROW), IX(NROW)
      NOP=NROW/NP
      IF (ICASE.GT.2) GO TO 2
      DO 1 KK=1,NOP
      KA=(KK-1)*NP+1
1     CALL FACTR (NP,A(KA),IP(KA),NROW)
      RETURN
2     IF (ICASE.GT.3) GO TO 3
C
C     FACTOR SUBMATRICIES, OR FACTOR COMPLETE MATRIX IF NO SYMMETRY
C     EXISTS.
C
      CALL FACIO (A,NROW,NOP,IX,IU1,IU2,IU3,IU4)
      CALL LUNSCR (A,NROW,NOP,IP,IX,IU2,IU3,IU4)
      RETURN
C
C     REWRITE THE MATRICES BY COLUMNS ON TAPE 13
C
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) GO TO 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) GO TO 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
      COMPLEX*16 FUNCTION FBAR(P)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     FBAR IS SOMMERFELD ATTENUATION FUNCTION FOR NUMERICAL DISTANCE P
C
      COMPLEX*16 Z,ZS,SUM,POW,TERM,P,FJ
      DIMENSION FJX(2)
      EQUIVALENCE (FJ,FJX)
      DATA TOSP/1.128379167D+0/,ACCS/1.D-12/,SP/1.772453851D+0/
     1,FJX/0.,1./
      Z=FJ*SQRT(P)
      IF (ABS(Z).GT.3.) GO TO 3
C
C     SERIES EXPANSION
C
      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=DREAL(TERM*DCONJG(TERM))
      SMS=DREAL(SUM*DCONJG(SUM))
      IF (TMS/SMS.LT.ACCS) GO TO 2
1     CONTINUE
2     FBAR=1.-(1.-SUM*TOSP)*Z*EXP(ZS)*SP
      RETURN
C
C     ASYMPTOTIC EXPANSION
C
3     IF (DREAL(Z).GE.0.) GO TO 4
      MINUS=1
      Z=-Z
      GO TO 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
      SUBROUTINE FBLOCK (NROW,NCOL,IMAX,IRNGF,IPSYM)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C     FBLOCK SETS PARAMETERS FOR OUT-OF-CORE SOLUTION FOR THE PRIMARY
C     MATRIX (A)
      COMPLEX*16 SSX,DETER
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
     1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
      COMMON /SMAT/ SSX(16,16)
      IMX1=IMAX-IRNGF
      IF (NROW*NCOL.GT.IMX1) GO TO 2
      NBLOKS=1
      NPBLK=NROW
      NLAST=NROW
      IMAT=NROW*NCOL
      IF (NROW.NE.NCOL) GO TO 1
      ICASE=1
      RETURN
1     ICASE=2
      GO TO 5
2     IF (NROW.NE.NCOL) GO TO 3
      ICASE=3
      NPBLK=IMAX/(2*NCOL)
      NPSYM=IMX1/NCOL
      IF (NPSYM.LT.NPBLK) NPBLK=NPSYM
      IF (NPBLK.LT.1) GO TO 12
      NBLOKS=(NROW-1)/NPBLK
      NLAST=NROW-NBLOKS*NPBLK
      NBLOKS=NBLOKS+1
      NBLSYM=NBLOKS
      NPSYM=NPBLK
      NLSYM=NLAST
      IMAT=NPBLK*NCOL
      WRITE(3,14)  NBLOKS,NPBLK,NLAST
      GO TO 11
3     NPBLK=IMAX/NCOL
      IF (NPBLK.LT.1) GO TO 12
      IF (NPBLK.GT.NROW) NPBLK=NROW
      NBLOKS=(NROW-1)/NPBLK
      NLAST=NROW-NBLOKS*NPBLK
      NBLOKS=NBLOKS+1
      WRITE(3,14)  NBLOKS,NPBLK,NLAST
      IF (NROW*NROW.GT.IMX1) GO TO 4
      ICASE=4
      NBLSYM=1
      NPSYM=NROW
      NLSYM=NROW
      IMAT=NROW*NROW
      WRITE(3,15)
      GO TO 5
4     ICASE=5
      NPSYM=IMAX/(2*NROW)
      NBLSYM=IMX1/NROW
      IF (NBLSYM.LT.NPSYM) NPSYM=NBLSYM
      IF (NPSYM.LT.1) GO TO 12
      NBLSYM=(NROW-1)/NPSYM
      NLSYM=NROW-NBLSYM*NPSYM
      NBLSYM=NBLSYM+1
      WRITE(3,16)  NBLSYM,NPSYM,NLSYM
      IMAT=NPSYM*NROW
5     NOP=NCOL/NROW
      IF (NOP*NROW.NE.NCOL) GO TO 13
      IF (IPSYM.GT.0) GO TO 7
C
C     SET UP SSX MATRIX FOR ROTATIONAL SYMMETRY.
C
      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)=DCMPLX(COS(ARG),SIN(ARG))
6     SSX(J,I)=SSX(I,J)
      GO TO 11
C
C     SET UP SSX MATRIX FOR PLANE SYMMETRY
C
7     KK=1
      SSX(1,1)=(1.,0.)
      IF ((NOP.EQ.2).OR.(NOP.EQ.4).OR.(NOP.EQ.8)) GO TO 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(3,17)  NROW,NCOL
      STOP
13    WRITE(3,18)  NROW,NCOL
      STOP
C
14    FORMAT (//35H MATRIX FILE STORAGE -  NO. BLOCKS=,I5,19H COLUMNS PE
     1R BLOCK=,I5,23H COLUMNS IN LAST BLOCK=,I5)
15    FORMAT (25H SUBMATRICIES FIT IN CORE)
16    FORMAT (38H SUBMATRIX PARTITIONING -  NO. BLOCKS=,I5,19H COLUMNS P
     1ER BLOCK=,I5,23H COLUMNS IN LAST BLOCK=,I5)
17    FORMAT (40H ERROR - INSUFFICIENT STORAGE FOR MATRIX,2I5)
18    FORMAT (28H SYMMETRY ERROR - NROW,NCOL=,2I5)
      END
      SUBROUTINE FBNGF (NEQ,NEQ2,IRESRV,IB11,IC11,ID11,IX11)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C     FBNGF SETS THE BLOCKING PARAMETERS FOR THE B, C, AND D ARRAYS FOR
C     OUT-OF-CORE STORAGE.
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
     1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
      IRESX=IRESRV-IMAT
      NBLN=NEQ*NEQ2
      NDLN=NEQ2*NEQ2
      NBCD=2*NBLN+NDLN
      IF (NBCD.GT.IRESX) GO TO 1
      ICASX=1
      IB11=IMAT+1
      GO TO 2
1     IF (ICASE.LT.3) GO TO 3
      IF (NBCD.GT.IRESRV.OR.NBLN.GT.IRESX) GO TO 3
      ICASX=2
      IB11=1
2     NBBX=1
      NPBX=NEQ
      NLBX=NEQ
      NBBL=1
      NPBL=NEQ2
      NLBL=NEQ2
      GO TO 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) GO TO 4
      NLBL=IRESX/NEQ
      IF (NLBL.LT.NPBL) NPBL=NLBL
4     IF (NPBL.LT.1) GO TO 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(3,11)  NEQ2
      IF (ICASX.EQ.1) RETURN
      WRITE(3,8)  ICASX
      WRITE(3,9)  NBBX,NPBX,NLBX
      WRITE(3,10)  NBBL,NPBL,NLBL
      RETURN
6     WRITE(3,7)  IRESRV,IMAT,NEQ,NEQ2
      STOP
C
7     FORMAT (55H ERROR - INSUFFICIENT STORAGE FOR INTERACTION MATRICIES
     1,24H  IRESRV,IMAT,NEQ,NEQ2 =,4I5)
8     FORMAT (48H FILE STORAGE FOR NEW MATRIX SECTIONS -  ICASX =,I2)
9     FORMAT (19H B FILLED BY ROWS -,15X,12HNO. BLOCKS =,I3,3X,16HROWS P
     1ER BLOCK =,I3,3X,20HROWS IN LAST BLOCK =,I3)
10    FORMAT (32H B BY COLUMNS, C AND D BY ROWS -,2X,12HNO. BLOCKS =,I3,
     14X,15HR/C PER BLOCK =,I3,4X,19HR/C IN LAST BLOCK =,I3)
11    FORMAT (//,35H N.G.F. - NUMBER OF NEW UNKNOWNS IS,I4)
      END
      SUBROUTINE FFLD (THET,PHI,ETH,EPH)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     FFLD CALCULATES THE FAR ZONE RADIATED ELECTRIC FIELDS,
C     THE FACTOR EXP(J*K*R)/(R/LAMDA) NOT INCLUDED
C
      COMPLEX*16 CIX,CIY,CIZ,EXA,ETH,EPH,CONST,CCX,CCY,CCZ,CDP,CUR
      COMPLEX*16 ZRATI,ZRSIN,RRV,RRH,RRV1,RRH1,RRV2,RRH2,ZRATI2,TIX,TIY
     1,TIZ,T1,ZSCRN,EX,EY,EZ,GX,GY,GZ,FRATI
      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM
      COMMON /ANGL/ SALP(MAXSEG)
      COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),
     &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)
      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,
     &KSYMP,IFAR,IPERF
      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
      IF (N.EQ.0) GO TO 20
C
C     LOOP FOR STRUCTURE IMAGE IF ANY
C
      DO 19 K=1,KSYMP
C
C     CALCULATION OF REFLECTION COEFFECIENTS
C
      IF (K.EQ.1) GO TO 4
      IF (IPERF.NE.1) GO TO 1
C
C     FOR PERFECT GROUND
C
      RRV=-(1.,0.)
      RRH=-(1.,0.)
      GO TO 2
C
C     FOR INFINITE PLANAR GROUND
C
1     ZRSIN=SQRT(1.-ZRATI*ZRATI*THZ*THZ)
      RRV=-(ROZ-ZRATI*ZRSIN)/(ROZ+ZRATI*ZRSIN)
      RRH=(ZRATI*ROZ-ZRSIN)/(ZRATI*ROZ+ZRSIN)
2     IF (IFAR.LE.1) GO TO 3
C
C     FOR THE CLIFF PROBLEM, TWO REFLCTION COEFFICIENTS CALCULATED
C
      RRV1=RRV
      RRH1=RRH
      TTHET=TAN(THET)
      IF (IFAR.EQ.4) GO TO 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.)
      CIZ=(0.,0.)
C
C     LOOP OVER STRUCTURE SEGMENTS
C
      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) GO TO 5
      A=2.*SIN(SILL)/OMEGA
      GO TO 6
5     A=(2.-OMEGA*OMEGA*EL*EL/3.)*EL
6     IF (ABS(TOP).LT.1.D-7) GO TO 7
      TOO=SIN(TOP)/TOP
      GO TO 8
7     TOO=1.-TOP*TOP/6.
8     IF (ABS(BOT).LT.1.D-7) GO TO 9
      BOO=SIN(BOT)/BOT
      GO TO 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) GO TO 11
      EXA=DCMPLX(COS(ARG),SIN(ARG))*DCMPLX(RR,RI)
C
C     SUMMATION FOR FAR FIELD INTEGRAL
C
      CIX=CIX+EXA*CAB(I)
      CIY=CIY+EXA*SAB(I)
      CIZ=CIZ+EXA*SALP(I)
      GO TO 17
C
C     CALCULATION OF IMAGE CONTRIBUTION IN CLIFF AND GROUND SCREEN
C     PROBLEMS.
C
11    DR=Z(I)*TTHET
C
C     SPECULAR POINT DISTANCE
C
      D=DR*PHY+X(I)
      IF (IFAR.EQ.2) GO TO 13
      D=SQRT(D*D+(Y(I)-DR*PHX)**2)
      IF (IFAR.EQ.3) GO TO 13
      IF ((SCRWL-D).LT.0.) GO TO 12
C
C     RADIAL WIRE GROUND SCREEN REFLECTION COEFFICIENT
C
      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)
      GO TO 16
12    IF (IFAR.EQ.4) GO TO 14
      IF (IFAR.EQ.5) D=DR*PHY+X(I)
13    IF ((CL-D).LE.0.) GO TO 15
14    RRV=RRV1
      RRH=RRH1
      GO TO 16
15    RRV=RRV2
      RRH=RRH2
      ARG=ARG+DARG
16    EXA=DCMPLX(COS(ARG),SIN(ARG))*DCMPLX(RR,RI)
C
C     CONTRIBUTION OF EACH IMAGE SEGMENT MODIFIED BY REFLECTION COEF. ,
C     FOR CLIFF AND GROUND SCREEN PROBLEMS
C
      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) GO TO 19
      IF (IFAR.GE.2) GO TO 18
C
C     CALCULATION OF CONTRIBUTION OF STRUCTURE IMAGE FOR INFINITE GROUND
C
      CDP=(CIX*PHX+CIY*PHY)*(RRH-RRV)
      CIX=CCX+CIX*RRV+CDP*PHX
      CIY=CCY+CIY*RRV+CDP*PHY
      CIZ=CCZ-CIZ*RRV
      GO TO 19
18    CIX=CIX+CCX
      CIY=CIY+CCY
      CIZ=CIZ+CCZ
19    CONTINUE
      IF (M.GT.0) GO TO 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.)
21    ROZ=ROZS
C
C     ELECTRIC FIELD COMPONENTS
C
      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) GO TO 22
      EX=GX
      EY=GY
      EZ=GZ
      GO TO 25
22    IF (IPERF.NE.1) GO TO 23
      GX=-GX
      GY=-GY
      GZ=-GZ
      GO TO 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
      SUBROUTINE FFLDS (ROX,ROY,ROZ,SCUR,EX,EY,EZ)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C     CALCULATES THE XYZ COMPONENTS OF THE ELECTRIC FIELD DUE TO
C     SURFACE CURRENTS
      COMPLEX*16 CT,CONS,SCUR,EX,EY,EZ
      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,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=DCMPLX(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
      SUBROUTINE GF (ZK,CO,SI)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     GF COMPUTES THE INTEGRAND EXP(JKR)/(KR) FOR NUMERICAL INTEGRATION.
C
      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) GO TO 3
      CO=(COS(RK)-1.)/RK
      RETURN
3     RKS=RK*RK
      CO=((-1.38888889D-3*RKS+4.16666667D-2)*RKS-.5)*RK
      RETURN
      END
      SUBROUTINE GFIL (IPRT)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      PARAMETER (IRESRV=MAXMAT**2)
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     GFIL READS THE N.G.F. FILE
C
      COMPLEX*16 CM,SSX,ZRATI,ZRATI2,T1,ZARRAY,AR1,AR2,AR3,EPSCF,FRATI
      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM
      COMMON /CMB/ CM(IRESRV)
      COMMON /ANGL/ SALP(MAXSEG)
      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,
     &KSYMP,IFAR,IPERF
      COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),DY
     1A(3),XSA(3),YSA(3),NXA(3),NYA(3)
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
     1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
      COMMON /SMAT/ SSX(16,16)
      COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF
      COMMON/SAVE/EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(2*MAXSEG),KCOM
      COMMON/CSAVE/COM(19,5)
C
C*** ERROR CORRECTED 11/20/89 *******************************
      DIMENSION T2X(1),T2Y(1),T2Z(1)
      EQUIVALENCE (T2X,ICON1),(T2Y,ICON2),(T2Z,ITAG)
C***
      DATA IGFL/20/
      OPEN(UNIT=IGFL,FILE='NGF2D.NEC',FORM='UNFORMATTED',STATUS='OLD')
      REWIND IGFL
      READ (IGFL) N1,NP,M1,MP,WLAM,FMHZ,IPSYM,KSYMP,IPERF,NRADL,EPSR,SIG
     1,SCRWLT,SCRWRT,NLODF,KCOM
      N=N1
      M=M1
      N2=N1+1
      M2=M1+1
      IF (N1.EQ.0) GO TO 2
C     READ SEG. DATA AND CONVERT BACK TO END COORD. IN UNITS OF METERS
      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) GO TO 4
      J=LD-M1+1
C     READ PATCH DATA AND CONVERT TO METERS
      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)
C*** ERROR CORRECTED 11/20/89 *******************************
      READ (IGFL) (T2X(I),I=J,LD),(T2Y(I),I=J,LD)
      READ (IGFL) (T2Z(I),I=J,LD)
C      READ (IGFL) (ICON1(I),I=J,LD),(ICON2(I),I=J,LD)
C      READ (IGFL) (ITAG(I),I=J,LD)
C
      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,
     1NYA
      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)
      READ (IGFL) (IP(I),I=1,NEQ),COM
C     READ MATRIX A AND WRITE TAPE13 FOR OUT OF CORE
      IF (ICASE.GT.2) GO TO 5
      IOUT=NEQ*NPEQ
      READ (IGFL) (CM(I),I=1,IOUT)
      GO TO 10
5     REWIND 13
      IF (ICASE.NE.4) GO TO 7
      IOUT=NPEQ*NPEQ
      DO 6 K=1,NOP
      READ (IGFL) (CM(J),J=1,IOUT)
6     WRITE (13) (CM(J),J=1,IOUT)
      GO TO 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
10    REWIND IGFL
C     WRITE(3,N) G.F. HEADING
      WRITE(3,16)
      WRITE(3,14)
      WRITE(3,14)
      WRITE(3,17)
      WRITE(3,18)  N1,M1
      IF (NOP.GT.1) WRITE(3,19)  NOP
      WRITE(3,20)  IMAT,ICASE
      IF (ICASE.LT.3) GO TO 11
      NBL2=NEQ*NPEQ
      WRITE(3,21)  NBL2
11    WRITE(3,22)  FMHZ
      IF (KSYMP.EQ.2.AND.IPERF.EQ.1) WRITE(3,23)
      IF (KSYMP.EQ.2.AND.IPERF.EQ.0) WRITE(3,27)
      IF (KSYMP.EQ.2.AND.IPERF.EQ.2) WRITE(3,28)
      IF (KSYMP.EQ.2.AND.IPERF.NE.1) WRITE(3,24)  EPSR,SIG
      WRITE(3,17)
      DO 12 J=1,KCOM
12    WRITE(3,15)  (COM(I,J),I=1,19)
      WRITE(3,17)
      WRITE(3,14)
      WRITE(3,14)
      WRITE(3,16)
      IF (IPRT.EQ.0) RETURN
      WRITE(3,25)
      DO 13 I=1,N1
13    WRITE(3,26)  I,X(I),Y(I),Z(I),SI(I),ALP(I),BET(I)
      RETURN
C
14    FORMAT (5X,50H**************************************************,
     &34H**********************************)
15    FORMAT (5X,3H** ,19A4,3H **)
16    FORMAT (////)
17    FORMAT (5X,2H**,80X,2H**)
18    FORMAT (5X,29H** NUMERICAL GREEN











'S FUNCTION,53X,2H**,/,5X,17H** NO     1. SEGMENTS =,I4,10X,13HNO. PATCHES =,I4,34X,2H**)19    FORMAT (5X,27H** NO. SYMMETRIC SECTIONS =,I4,51X,2H**)20    FORMAT (5X,34H** N.G.F. MATRIX -  CORE STORAGE =,I7,23H COMPLEX NU     1MBERS,  CASE,I2,16X,2H**)21    FORMAT (5X,2H**,19X,13HMATRIX SIZE =,I7,16H COMPLEX NUMBERS,25X,2H     1**)22    FORMAT (5X,14H** FREQUENCY =,1P,E12.5,5H MHZ.,51X,2H**)23    FORMAT (5X,17H** PERFECT GROUND,65X,2H**)24    FORMAT (5X,44H** GROUND PARAMETERS - DIELECTRIC CONSTANT =,1P,     1E12.5,26X,2H**,/,5X,2H**,21X,14HCONDUCTIVITY =,E12.5,8H MHOS/M.,     225X,2H**)25    FORMAT (39X,31HNUMERICAL GREEN'S FUNCTION DATA,/,41X,27HCOORDINATE
     1S OF SEGMENT ENDS,/,51X,8H(METERS),/,5X,4HSEG.,11X,19H- - - END ON
     2E - - -,26X,19H- - - END TWO - - -,/,6X,3HNO.,6X,1HX,14X,1HY,14X,1
     3HZ,14X,1HX,14X,1HY,14X,1HZ)
26    FORMAT (1X,I7,1P,6E15.6)
27    FORMAT (5X,55H** FINITE GROUND.  REFLECTION COEFFICIENT APPROXIMAT
     1ION,27X,2H**)
28    FORMAT (5X,38H** FINITE GROUND.  SOMMERFELD SOLUTION,44X,2H**)
      END
      SUBROUTINE GFLD (RHO,PHI,RZ,ETH,EPI,ERD,UX,KSYMP)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     GFLD COMPUTES THE RADIATED FIELD INCLUDING GROUND WAVE.
C
      COMPLEX*16 CUR,EPI,CIX,CIY,CIZ,EXA,XX1,XX2,U,U2,ERV,EZV,ERH,EPH
      COMPLEX*16 EZH,EX,EY,ETH,UX,ERD
      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM
      COMMON /ANGL/ SALP(MAXSEG)
      COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),
     &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)
      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) GO TO 1
      IF (ABS(UX).GT..5) GO TO 1
      IF (R.GT.1.E5) GO TO 1
      GO TO 4
C
C     COMPUTATION OF SPACE WAVE ONLY
C
1     IF (RZ.LT.1.D-20) GO TO 2
      THET=ATAN(RHO/RZ)
      GO TO 3
2     THET=PI*.5
3     CALL FFLD (THET,PHI,ETH,EPI)
      ARG=-TP*R
      EXA=DCMPLX(COS(ARG),SIN(ARG))/R
      ETH=ETH*EXA
      EPI=EPI*EXA
      ERD=(0.,0.)
      RETURN
C
C     COMPUTATION OF SPACE AND GROUND WAVES.
C
4     U=UX
      U2=U*U
      PHX=-SIN(PHI)
      PHY=COS(PHI)
      RX=RHO*PHY
      RY=-RHO*PHX
      CIX=(0.,0.)
      CIY=(0.,0.)
      CIZ=(0.,0.)
C
C     SUMMATION OF FIELD FROM INDIVIDUAL SEGMENTS
C
      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) GO TO 5
      RHX=RIX/RHP
      RHY=RIY/RHP
      GO TO 6
5     RHX=1.
      RHY=0.
6     CALP=1.-DZ*DZ
      IF (CALP.LT.1.D-6) GO TO 7
      CALP=SQRT(CALP)
      CBET=DX/CALP
      SBET=DY/CALP
      CPH=RHX*CBET+RHY*SBET
      SPH=RHY*CBET-RHX*SBET
      GO TO 8
7     CPH=RHX
      SPH=RHY
8     EL=PI*SI(I)
      RFL=-1.
C
C     INTEGRATION OF (CURRENT)*(PHASE FACTOR) OVER SEGMENT AND IMAGE FOR
C     CONSTANT, SINE, AND COSINE CURRENT DISTRIBUTIONS
C
      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) GO TO 9
      A=2.*SIN(SILL)/OMEGA
      GO TO 10
9     A=(2.-OMEGA*OMEGA*EL*EL/3.)*EL
10    IF (ABS(TOP).LT.1.D-7) GO TO 11
      TOO=SIN(TOP)/TOP
      GO TO 12
11    TOO=1.-TOP*TOP/6.
12    IF (ABS(BOT).LT.1.D-7) GO TO 13
      BOO=SIN(BOT)/BOT
      GO TO 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=DCMPLX(COS(ARG),SIN(ARG))*DCMPLX(RR,RI)/TP
      IF (K.EQ.2) GO TO 15
      XX1=EXA
      R1=RXYZ
      ZMH=RIZ
      GO TO 16
15    XX2=EXA
      R2=RXYZ
      ZPH=RIZ
16    CONTINUE
C
C     CALL SUBROUTINE TO COMPUTE THE FIELD OF SEGMENT INCLUDING GROUND
C     WAVE.
C
      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=DCMPLX(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
      SUBROUTINE GFOUT
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      PARAMETER (IRESRV=MAXMAT**2)
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     WRITE N.G.F. FILE
C
      COMPLEX*16 CM,SSX,ZRATI,ZRATI2,T1,ZARRAY,AR1,AR2,AR3,EPSCF,FRATI
      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM
      COMMON /CMB/ CM(IRESRV)
      COMMON /ANGL/ SALP(MAXSEG)
      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,
     &KSYMP,IFAR,IPERF
      COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),DY
     1A(3),XSA(3),YSA(3),NXA(3),NYA(3)
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
     1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
      COMMON /SMAT/ SSX(16,16)
      COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF
      COMMON/SAVE/EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(2*MAXSEG),KCOM
      COMMON/CSAVE/COM(19,5)
C
C*** ERROR CORRECTED 11/20/89 *******************************
      DIMENSION T2X(1),T2Y(1),T2Z(1)
      EQUIVALENCE (T2X,ICON1),(T2Y,ICON2),(T2Z,ITAG)
C***
      DATA IGFL/20/
      OPEN(UNIT=IGFL,FILE='NGF2D.NEC',FORM='UNFORMATTED',STATUS='NEW')
      NEQ=N+2*M
      NPEQ=NP+2*MP
      NOP=NEQ/NPEQ
      WRITE (IGFL) N,NP,M,MP,WLAM,FMHZ,IPSYM,KSYMP,IPERF,NRADL,EPSR,
     1SIG,SCRWLT,SCRWRT,NLOAD,KCOM
      IF (N.EQ.0) GO TO 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) GO TO 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)
C
C*** ERROR CORRECTED 11/20/89 *******************************
                                                             
      WRITE (IGFL) (T2X(I),I=J,LD),(T2Y(I),I=J,LD)
      WRITE (IGFL) (T2Z(I),I=J,LD)
C      WRITE (IGFL) (ICON1(I),I=J,LD),(ICON2(I),I=J,LD)
C      WRITE (IGFL) (ITAG(I),I=J,LD)
C
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
     1,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) GO TO 3
      IOUT=NEQ*NPEQ
      WRITE (IGFL) (CM(I),I=1,IOUT)
      GO TO 12
3     IF (ICASE.NE.4) GO TO 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
      GO TO 12
5     REWIND 13
      REWIND 14
      IF (ICASE.EQ.5) GO TO 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)
      GO TO 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(3,13)  IGFL,IMAT
      RETURN
C
13    FORMAT (///,44H ****NUMERICAL GREEN





































































































































































'S FUNCTION FILE ON TAPE,I3,5H     1****,/,5X,16HMATRIX STORAGE -,I7,16H COMPLEX NUMBERS,///)      END      SUBROUTINE GH (ZK,HR,HI)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***C     INTEGRAND FOR H FIELD OF A WIRE      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      SUBROUTINE GWAVE (ERV,EZV,ERH,EZH,EPH)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***CC     GWAVE COMPUTES THE ELECTRIC FIELD, INCLUDING GROUND WAVE, OF AC     CURRENT ELEMENT OVER A GROUND PLANE USING FORMULAS OF K.A. NORTONC     (PROC. IRE, SEPT., 1937, PP.1203,1236.)C      COMPLEX*16 FJ,TPJ,U2,U,RK1,RK2,T1,T2,T3,T4,P1,RV,OMR,W,F,Q1,RH,V,G     1,XR1,XR2,X1,X2,X3,X4,X5,X6,X7,EZV,ERV,EZH,ERH,EPH,XX1,XX2,ECON,     2FBAR      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 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      SUBROUTINE GX (ZZ,RH,XK,GZ,GZP)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***C     SEGMENT END CONTRIBUTIONS FOR THIN WIRE APPROX.      COMPLEX*16 GZ,GZP      R2=ZZ*ZZ+RH*RH      R=SQRT(R2)      RK=XK*R      GZ=DCMPLX(COS(RK),-SIN(RK))/R      GZP=-DCMPLX(1.D+0,RK)*GZ/R2      RETURN      END      SUBROUTINE GXX (ZZ,RH,A,A2,XK,IRA,G1,G1P,G2,G2P,G3,GZP)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***C     SEGMENT END CONTRIBUTIONS FOR EXT. THIN WIRE APPROX.      COMPLEX*16 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=DCMPLX(1.D+0,RK)      C2=3.*C1-RK2      C3=DCMPLX(6.D+0,RK)*RK2-15.*C1      GZ=DCMPLX(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) GO TO 2      G3=(G3+GZP)*RH      GZP=-ZZ*C1*GZ      IF (RH.GT.1.D-10) GO TO 1      G2=0.      G2P=0.      RETURN1     G2=G2/RH      G2P=G2P*ZZ/RH      RETURN2     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      SUBROUTINE HELIX(S,HL,A1,B1,A2,B2,RAD,NS,ITG)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC















































'      IMPLICIT REAL*8(A-H,O-Z)C ***C     SUBROUTINE HELIX GENERATES SEGMENT GEOMETRY DATA FOR A HELIX OF NSC     SEGMENTS      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,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) GO TO 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)      GO TO 2010    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) GO TO 25      COPY=X(I)      X(I)=Y(I)      Y(I)=COPY      COPY=X2(I)      X2(I)=Y2(I)      Y2(I)=COPY25    CONTINUE      IF(A2.EQ.A1) GO TO 21      SANGLE=ATAN(A2/(ABS(HL)+(ABS(HL)*A1)/(A2-A1)))      WRITE(3,104)  SANGLE104   FORMAT(5X,'THE CONE ANGLE OF THE SPIRAL IS


















',F10.4)      RETURN21    IF(A1.NE.B1) GO TO 30      HDIA=2.*A1      TURN=HDIA*PI      PITCH=ATAN(S/(PI*HDIA))      TURN=TURN/COS(PITCH)      PITCH=180.*PITCH/PI      GO TO 4030    IF(A1.LT.B1) GO TO 34      HMAJ=2.*A1      HMIN=2.*B1      GO TO 3534    HMAJ=2.*B1      HMIN=2.*A135    HDIA=SQRT((HMAJ**2+HMIN**2)/2*HMAJ)      TURN=2.*PI*HDIA      PITCH=(180./PI)*ATAN(S/(PI*HDIA))40    WRITE(3,105) PITCH,TURN105   FORMAT(5X,'THE PITCH ANGLE IS',F10.4/5X,'THE LENGTH OF WIRE/TURN I
     1S










































































































































































































































































































































































































































































































































































































































',F10.4)      RETURN      END      SUBROUTINE HFK (EL1,EL2,RHK,ZPKX,SGR,SGI)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***C     HFK COMPUTES THE H FIELD OF A UNIFORM CURRENT FILAMENT BYC     NUMERICAL INTEGRATION      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,22     DZ=ZE-Z      IF (ABS(DZ)-EP) 17,17,33     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.D0)      IF (TE1I-RX) 5,5,65     IF (TE1R-RX) 8,8,66     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.D0)      IF (TE2I-RX) 7,7,147     IF (TE2R-RX) 9,9,148     SGR=SGR+T10R      SGI=SGI+T10I      NT=NT+2      GO TO 109     SGR=SGR+T20R      SGI=SGI+T20I      NT=NT+110    Z=Z+DZ      IF (Z-ZEND) 11,17,1711    G1R=G5R      G1I=G5I      IF (NT-NTS) 1,12,1212    IF (NS-NX) 1,1,1313    NS=NS/2      NT=1      GO TO 114    NT=0      IF (NS-NM) 16,15,1515    WRITE(3,18)  Z      GO TO 916    NS=NS*2      DZ=S/NS      DZOT=DZ*0.5      G5R=G3R      G5I=G3I      G3R=G2R      G3I=G2I      GO TO 417    CONTINUE      SGR=SGR*RHK*.5      SGI=SGI*RHK*.5      RETURNC18    FORMAT (24H STEP SIZE LIMITED AT Z=,F10.5)      END      SUBROUTINE HINTG (XI,YI,ZI)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***C     HINTG COMPUTES THE H FIELD OF A PATCH CURRENT      COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,ZRATI,ZRATI2,GAM     1,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,IND1,INDD1,IND2,INDD2,IEXK,IPGND      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,     &KSYMP,IFAR,IPERF      EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y     1J,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) GO TO 5      R=SQRT(RSQ)      RK=TP*R      CR=COS(RK)      SR=SIN(RK)      GAM=-(DCMPLX(CR,-SR)+RK*DCMPLX(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) GO TO 4      IF (IPERF.NE.1) GO TO 1      F1X=-F1X      F1Y=-F1Y      F1Z=-F1Z      F2X=-F2X      F2Y=-F2Y      F2Z=-F2Z      GO TO 41     XYMAG=SQRT(RX*RX+RY*RY)      IF (XYMAG.GT.1.D-6) GO TO 2      PX=0.      PY=0.      CTH=1.      RRV=(1.,0.)      GO TO 32     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*RRH4     EXK=EXK+F1X      EYK=EYK+F1Y      EZK=EZK+F1Z      EXS=EXS+F2X      EYS=EYS+F2Y      EZS=EZS+F2Z5     CONTINUE      RETURN      END      SUBROUTINE HSFLD (XI,YI,ZI,AI)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***C     HSFLD COMPUTES THE H FIELD FOR CONSTANT, SINE, AND COSINE CURRENTC     ON A SEGMENT INCLUDING GROUND EFFECTS.      COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,ZRATI,ZRATI2,T1     1,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,IND1,INDD1,IND2,INDD2,IEXK,IPGND      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,     &KSYMP,IFAR,IPERF      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) GO TO 1      EXK=0.      EYK=0.      EZK=0.      EXS=0.      EYS=0.      EZS=0.      EXC=0.      EYC=0.      EZC=0.      GO TO 71     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) GO TO 6      IF (IPERF.EQ.1) GO TO 5      ZRATX=ZRATI      RMAG=SQRT(ZP*ZP+RH*RH)      XYMAG=SQRT(XIJ*XIJ+YIJ*YIJ)CC     SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.C      IF (NRADL.EQ.0) GO TO 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) GO TO 2      RRV=T1*RHOSPC*LOG(RHOSPC/T2)      ZRATX=(RRV*ZRATI)/(ETA*ZRATI+RRV)2     IF (XYMAG.GT.1.D-6) GO TO 3CC     CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.C      PX=0.      PY=0.      CTH=1.      RRV=(1.,0.)      GO TO 43     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      GO TO 75     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      GO TO 76     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*PHZ7     CONTINUE      RETURN      END      SUBROUTINE HSFLX (S,RH,ZPX,HPK,HPS,HPC)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***C     CALCULATES H FIELD OF SINE COSINE, AND CONSTANT CURRENT OF SEGMENT      COMPLEX*16 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) GO TO 6      IF (ZPX.LT.0.) GO TO 1      ZP=ZPX      HSS=1.      GO TO 21     ZP=-ZPX      HSS=-1.2     DH=.5*S      Z1=ZP+DH      Z2=ZP-DH      IF (Z2.LT.1.D-7) GO TO 3      RHZ=RH/Z2      GO TO 43     RHZ=1.4     DK=TP*DH      CDK=COS(DK)      SDK=SIN(DK)      CALL HFK (-DK,DK,RH*TP,ZP*TP,HKR,HKI)      HPK=DCMPLX(HKR,HKI)      IF (RHZ.LT.1.D-3) GO TO 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      RETURN5     EKR1=DCMPLX(CDK,SDK)/(Z2*Z2)      EKR2=DCMPLX(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)      RETURN6     HPS=(0.,0.)      HPC=(0.,0.)      HPK=(0.,0.)      RETURN      END      SUBROUTINE INTRP (X,Y,F1,F2,F3,F4)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***CC     INTRP USES BIVARIATE CUBIC INTERPOLATION TO OBTAIN THE VALUES OFC     4 FUNCTIONS AT THE POINT (X,Y).C      COMPLEX*16 F1,F2,F3,F4,A,B,C,D,FX1,FX2,FX3,FX4,P1,P2,P3,P4,A11,A12     1,A13,A14,A21,A22,A23,A24,A31,A32,A33,A34,A41,A42,A43,A44,B11,B12     2,B13,B14,B21,B22,B23,B24,B31,B32,B33,B34,B41,B42,B43,B44,C11,C12     3,C13,C14,C21,C22,C23,C24,C31,C32,C33,C34,C41,C42,C43,C44,D11,D12     4,D13,D14,D21,D22,D23,D24,D31,D32,D33,D34,D41,D42,D43,D44      COMPLEX*16 AR1,AR2,AR3,ARL1,ARL2,ARL3,EPSCF      COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),DY     1A(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     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     1,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) GO TO 1      IX=INT((X-XS)/DX)+1      IY=INT((Y-YS)/DY)+1CC     IF POINT LIES IN SAME 4 BY 4 POINT REGION AS PREVIOUS POINT, OLDC     VALUES ARE REUSEDC      IF (IX.LT.IXEG.OR.IY.LT.IYEG) GO TO 1      IF (IABS(IX-IXS).LT.2.AND.IABS(IY-IYS).LT.2) GO TO 12CC     DETERMINE CORRECT GRID AND GRID REGIONC1     IF (X.GT.XS2) GO TO 2      IGR=1      GO TO 32     IGR=2      IF (Y.GT.YS3) IGR=33     IF (IGR.EQ.IGRS) GO TO 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)+14     IXS=((IX-1)/3)*3+2      IF (IXS.LT.2) IXS=2      IXEG=-10000      IF (IXS.LE.NXM2) GO TO 5      IXS=NXM2      IXEG=NXMS5     IYS=((IY-1)/3)*3+2      IF (IYS.LT.2) IYS=2      IYEG=-10000      IF (IYS.LE.NYM2) GO TO 6      IYS=NYM2      IYEG=NYMSCC     COMPUTE COEFFICIENTS OF 4 CUBIC POLYNOMIALS IN X FOR THE 4 GRIDC     VALUES OF Y FOR EACH OF THE 4 FUNCTIONSC6     IADZ=IXS+(IYS-3)*ND-NDP      DO 11 K=1,4      IADZ=IADZ+NDP      IADD=IADZ      DO 11 I=1,4      IADD=IADD+ND      GO TO (7,8,9), IGRSC     P1=AR1(IXS-1,IYS-2+I,K)7     P1=ARL1(IADD-1)      P2=ARL1(IADD)      P3=ARL1(IADD+1)      P4=ARL1(IADD+2)      GO TO 108     P1=ARL2(IADD-1)      P2=ARL2(IADD)      P3=ARL2(IADD+1)      P4=ARL2(IADD+2)      GO TO 109     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+011    D(I,K)=P2      XZ=(IXS-1)*DX+XS      YZ=(IYS-1)*DY+YSCC     EVALUATE POLYMOMIALS IN X AND THEN USE CUBIC INTERPOLATION IN YC     FOR EACH OF THE 4 FUNCTIONS.C12    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      SUBROUTINE INTX (EL1,EL2,B,IJ,SGR,SGI)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***CC     INTX PERFORMS NUMERICAL INTEGRATION OF EXP(JKR)/R BY THE METHOD OFC     VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION.  THE INTEGRAND VALUEC     IS SUPPLIED BY SUBROUTINE GF.C      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,22     DZ=ZE-Z      IF (ABS(DZ)-EP) 17,17,33     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      T10I=(4.0*T01I-T00I)/3.0CC     TEST CONVERGENCE OF 3 POINT ROMBERG RESULT.C      CALL TEST (T01R,T10R,TE1R,T01I,T10I,TE1I,0.D0)      IF (TE1I-RX) 5,5,65     IF (TE1R-RX) 8,8,66     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      T20I=(16.0*T11I-T10I)/15.0CC     TEST CONVERGENCE OF 5 POINT ROMBERG RESULT.C      CALL TEST (T11R,T20R,TE2R,T11I,T20I,TE2I,0.D0)      IF (TE2I-RX) 7,7,147     IF (TE2R-RX) 9,9,148     SGR=SGR+T10R      SGI=SGI+T10I      NT=NT+2      GO TO 109     SGR=SGR+T20R      SGI=SGI+T20I      NT=NT+110    Z=Z+DZ      IF (Z-ZEND) 11,17,1711    G1R=G5R      G1I=G5I      IF (NT-NTS) 1,12,1212    IF (NS-NX) 1,1,13CC     DOUBLE STEP SIZEC13    NS=NS/2      NT=1      GO TO 114    NT=0      IF (NS-NM) 16,15,1515    WRITE(3,20)  Z      GO TO 9CC     HALVE STEP SIZEC16    NS=NS*2      FNS=NS      DZ=S/FNS      DZOT=DZ*0.5      G5R=G3R      G5I=G3I      G3R=G2R      G3I=G2I      GO TO 417    CONTINUE      IF (IJ) 19,18,19CC     ADD CONTRIBUTION OF NEAR SINGULARITY FOR DIAGONAL TERMC18    SGR=2.*(SGR+LOG((SQRT(B*B+S*S)+S)/B))      SGI=2.*SGI19    CONTINUE      RETURNC20    FORMAT (24H STEP SIZE LIMITED AT Z=,F10.5)      END      FUNCTION ISEGNO (ITAGI,MX)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC



































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     ISEGNO RETURNS THE SEGMENT NUMBER OF THE MTH SEGMENT HAVING THEC     TAG NUMBER ITAGI.  IF ITAGI=0 SEGMENT NUMBER M IS RETURNED.C      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      IF (MX.GT.0) GO TO 1      WRITE(3,6)      STOP1     ICNT=0      IF (ITAGI.NE.0) GO TO 2      ISEGNO=MX      RETURN2     IF (N.LT.1) GO TO 4      DO 3 I=1,N      IF (ITAG(I).NE.ITAGI) GO TO 3      ICNT=ICNT+1      IF (ICNT.EQ.MX) GO TO 53     CONTINUE4     WRITE(3,7)  ITAGI      STOP5     ISEGNO=I      RETURNC6     FORMAT (4X,91HCHECK DATA, PARAMETER SPECIFYING SEGMENT POSITION IN     1 A GROUP OF EQUAL TAGS MUST NOT BE ZERO)7     FORMAT (///,10X,26HNO SEGMENT HAS AN ITAG OF ,I5)      END      SUBROUTINE LFACTR (A,NROW,IX1,IX2,IP)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC














































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     LFACTR PERFORMS GAUSS-DOOLITTLE MANIPULATIONS ON THE TWO BLOCKS OFC     THE TRANSPOSED MATRIX IN CORE STORAGE.  THE GAUSS-DOOLITTLEC     ALGORITHM IS PRESENTED ON PAGES 411-416 OF A. RALSTON -- A FIRSTC     COURSE IN NUMERICAL ANALYSIS.  COMMENTS BELOW REFER TO COMMENTS INC     RALSTONS TEXT.C      COMPLEX*16 A,D,AJR      INTEGER R,R1,R2,PJ,PR      LOGICAL L1,L2,L3      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I     1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL      COMMON /SCRATM/ D(2*MAXSEG)      DIMENSION A(NROW,1), IP(NROW)      IFLG=0CC     INITIALIZE R1,R2,J1,J2C      L1=IX1.EQ.1.AND.IX2.EQ.2      L2=(IX2-1).EQ.IX1      L3=IX2.EQ.NBLSYM      IF (L1) GO TO 1      GO TO 21     R1=1      R2=2*NPSYM      J1=1      J2=-1      GO TO 52     R1=NPSYM+1      R2=2*NPSYM      J1=(IX1-1)*NPSYM+1      IF (L2) GO TO 3      GO TO 43     J2=J1+NPSYM-2      GO TO 54     J2=J1+NPSYM-15     IF (L3) R2=NPSYM+NLSYM      DO 16 R=R1,R2CC     STEP 1C      DO 6 K=J1,NROW      D(K)=A(K,R)6     CONTINUECC     STEPS 2 AND 3C      IF (L1.OR.L2) J2=J2+1      IF (J1.GT.J2) GO TO 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)*AJR7     CONTINUE8     CONTINUE9     CONTINUECC     STEP 4C      J2P1=J2+1      IF (L1.OR.L2) GO TO 11      IF (NROW.LT.J2P1) GO TO 16      DO 10 I=J2P1,NROW      A(I,R)=D(I)10    CONTINUE      GO TO 1611    DMAX=DREAL(D(J2P1)*DCONJG(D(J2P1)))      IP(J2P1)=J2P1      J2P2=J2+2      IF (J2P2.GT.NROW) GO TO 13      DO 12 I=J2P2,NROW      ELMAG=DREAL(D(I)*DCONJG(D(I)))      IF (ELMAG.LT.DMAX) GO TO 12      DMAX=ELMAG      IP(J2P1)=I12    CONTINUE13    CONTINUE      IF (DMAX.LT.1.D-10) IFLG=1      PR=IP(J2P1)      A(J2P1,R)=D(PR)      D(PR)=D(J2P1)CC     STEP 5C      IF (J2P2.GT.NROW) GO TO 15      AJR=1./A(J2P1,R)      DO 14 I=J2P2,NROW      A(I,R)=D(I)*AJR14    CONTINUE15    CONTINUE      IF (IFLG.EQ.0) GO TO 16      WRITE(3,17)  J2,DMAX      IFLG=016    CONTINUE      RETURNC17    FORMAT (1H ,6HPIVOT(,I3,2H)=,1P,E16.8)      END      SUBROUTINE LOAD (LDTYP,LDTAG,LDTAGF,LDTAGT,ZLR,ZLI,ZLC)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC










































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     LOAD CALCULATES THE IMPEDANCE OF SPECIFIED SEGMENTS FOR VARIOUSC     TYPES OF LOADINGC      COMPLEX*16 ZARRAY,ZT,TPCJ,ZINT      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF      DIMENSION LDTYP(1), LDTAG(1), LDTAGF(1), LDTAGT(1), ZLR(1), ZLI(1)     1, ZLC(1), TPCJX(2)      EQUIVALENCE (TPCJ,TPCJX)      DATA TPCJX/0.,1.883698955D+9/CC     WRITE(3,HEADING)C      WRITE(3,25)CC     INITIALIZE D ARRAY, USED FOR TEMPORARY STORAGE OF LOADINGC     INFORMATION.C      DO 1 I=N2,N 1    ZARRAY(I)=(0.,0.)      IWARN=0CC     CYCLE OVER LOADING CARDSC      ISTEP=0 2    ISTEP=ISTEP+1      IF (ISTEP.LE.NLOAD) GO TO 5      IF (IWARN.EQ.1) WRITE(3,26)      IF (N1+2*M1.GT.0) GO TO 4      NOP=N/NP      IF (NOP.EQ.1) GO TO 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) GO TO 6      WRITE(3,27)  LDTYP(ISTEP)      STOP 6    LDTAGS=LDTAG(ISTEP)      JUMP=LDTYP(ISTEP)+1      ICHK=0CC     SEARCH SEGMENTS FOR PROPER ITAGSC      L1=N2      L2=N      IF (LDTAGS.NE.0) GO TO 7      IF (LDTAGF(ISTEP).EQ.0.AND.LDTAGT(ISTEP).EQ.0) GO TO 7      L1=LDTAGF(ISTEP)      L2=LDTAGT(ISTEP)      IF (L1.GT.N1) GO TO 7      WRITE(3,29)      STOP 7    DO 17 I=L1,L2      IF (LDTAGS.EQ.0) GO TO 8      IF (LDTAGS.NE.ITAG(I)) GO TO 17      IF (LDTAGF(ISTEP).EQ.0) GO TO 8      ICHK=ICHK+1      IF (ICHK.GE.LDTAGF(ISTEP).AND.ICHK.LE.LDTAGT(ISTEP)) GO TO 9      GO TO 17 8    ICHK=1CC     CALCULATION OF LAMDA*IMPED. PER UNIT LENGTH, JUMP TO APPROPRIATEC     SECTION FOR LOADING TYPEC 9    GO TO (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))      GO TO 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      GO TO 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(ISTE     1P))      GO TO 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      GO TO 16 14   ZT=DCMPLX(ZLR(ISTEP),ZLI(ISTEP))/SI(I)      GO TO 16 15   ZT=ZINT(ZLR(ISTEP)*WLAM,BI(I)) 16   IF ((ABS(DREAL(ZARRAY(I)))+ABS(DIMAG(ZARRAY(I)))).GT.1.D-20)     1IWARN=1      ZARRAY(I)=ZARRAY(I)+ZT 17   CONTINUE      IF (ICHK.NE.0) GO TO 18      WRITE(3,28)  LDTAGS      STOPCC     PRINTING THE SEGMENT LOADING DATA, JUMP TO PROPER PRINTC 18   GO TO (19,20,21,22,23,24), JUMP 19   CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),ZLR(ISTEP),ZLI(ISTEP     1),ZLC(ISTEP),0.D0,0.D0,0.D0,' SERIES 


')      GO TO 2 20   CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),ZLR(ISTEP),ZLI(ISTEP     1),ZLC(ISTEP),0.D0,0.D0,0.D0,'PARALLEL


')      GO TO 2 21   CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),ZLR(ISTEP),ZLI(ISTEP     1),ZLC(ISTEP),0.D0,0.D0,0.D0,' SERIES (PER METER) 


')      GO TO 2 22   CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),ZLR(ISTEP),ZLI(ISTEP     1),ZLC(ISTEP),0.D0,0.D0,0.D0,'PARALLEL (PER METER)


')      GO TO 2 23   CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),0.D0,0.D0,0.D0,     &ZLR(ISTEP),ZLI(ISTEP),0.D0,'FIXED IMPEDANCE 


')      GO TO 2 24   CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),0.D0,0.D0,0.D0,0.D0,     &0.D0,ZLR(ISTEP),'  WIRE  



















')      GO TO 2C 25   FORMAT (//,7X,8HLOCATION,10X,10HRESISTANCE,3X,10HINDUCTANCE,2X,11H     1CAPACITANCE,7X,16HIMPEDANCE (OHMS),5X,12HCONDUCTIVITY,4X,4HTYPE,/,     24X,4HITAG,10H FROM THRU,10X,4HOHMS,8X,6HHENRYS,7X,6HFARADS,8X,4HRE     3AL,6X,9HIMAGINARY,4X,10HMHOS/METER) 26   FORMAT (/,10X,74HNOTE, SOME OF THE ABOVE SEGMENTS HAVE BEEN LOADED     1 TWICE - IMPEDANCES ADDED) 27   FORMAT (/,10X,46HIMPROPER LOAD TYPE CHOOSEN, REQUESTED TYPE IS ,I3     1) 28   FORMAT (/,10X,50HLOADING DATA CARD ERROR, NO SEGMENT HAS AN ITAG =     1 ,I5) 29   FORMAT (63H ERROR - LOADING MAY NOT BE ADDED TO SEGMENTS IN N.G.F.     1 SECTION)      END      SUBROUTINE LTSOLV (A,NROW,IX,B,NEQ,NRH,IFL1,IFL2)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC










































































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     LTSOLV SOLVES THE MATRIX EQ. Y(R)*LU(T)=B(R) WHERE (R) DENOTES ROWC     VECTOR AND LU(T) DENOTES THE LU DECOMPOSITION OF THE TRANSPOSE OFC     THE ORIGINAL COEFFICIENT MATRIX.  THE LU(T) DECOMPOSITION ISC     STORED ON TAPE 5 IN BLOCKS IN ASCENDING ORDER AND ON FILE 3 INC     BLOCKS OF DESCENDING ORDER.C      COMPLEX*16 A,B,Y,SUM      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I     1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL      COMMON /SCRATM/ Y(2*MAXSEG)      DIMENSION A(NROW,NROW), B(NEQ,NRH), IX(NEQ)CC     FORWARD SUBSTITUTIONC      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) GO TO 2      DO 1 I=1,JM11     SUM=SUM+A(I,K)*B(I,IC)2     B(J,IC)=(B(J,IC)-SUM)/A(J,K)3     CONTINUE4     CONTINUECC     BACKWARD SUBSTITUTIONC      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) GO TO 6      DO 5 I=JP1,NROW5     SUM=SUM+A(I,KP)*B(I,IC)      B(J,IC)=B(J,IC)-SUM6     CONTINUE7     CONTINUE8     JST=JST-K2CC     UNSCRAMBLE SOLUTIONC      DO 10 IC=1,NRH      DO 9 I=1,NROW      IXI=IX(I)9     Y(IXI)=B(I,IC)      DO 10 I=1,NROW10    B(I,IC)=Y(I)      RETURN      END      SUBROUTINE LUNSCR (A,NROW,NOP,IX,IP,IU2,IU3,IU4)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***CC     S/R WHICH UNSCRAMBLES, SCRAMBLED FACTORED MATRIXC      COMPLEX*16 A,TEMP      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I     1CASX,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) GO TO 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)=TEMP1     CONTINUE2     CONTINUE3     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)=I6     CONTINUE      DO 7 I=1,NROW      IPI=IP(I+KA)      IXT=IX(I+KA)      IX(I+KA)=IX(IPI+KA)      IX(IPI+KA)=IXT7     CONTINUE      IF (NOP.EQ.1) GO TO 9      NB1=NBLSYM-1C     SKIP NB1 LOGICAL RECORDS FORWARD      DO 8 IXBLK1=1,NB1      CALL BLCKIN (A,IU3,I1,I2,1,125)8     CONTINUE9     CONTINUE      REWIND IU2      REWIND IU3      REWIND IU4      RETURN      END      SUBROUTINE MOVE (ROX,ROY,ROZ,XS,YS,ZS,ITS,NRPT,ITGI)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC











































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     SUBROUTINE MOVE MOVES THE STRUCTURE WITH RESPECT TO ITSC     COORDINATE SYSTEM OR REPRODUCES STRUCTURE IN NEW POSITIONS.C     STRUCTURE IS ROTATED ABOUT X,Y,Z AXES BY ROX,ROY,ROZC     RESPECTIVELY, THEN SHIFTED BY XS,YS,ZSC      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /ANGL/ SALP(MAXSEG)      DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), X2(1), Y     12(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,ICON     12), (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) GO TO 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)+ITGI1     CONTINUE      I1=N+1      N=K2     CONTINUE3     IF (M.LT.M2) GO TO 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+15     M=K6     IF ((NRPT.EQ.0).AND.(IX.EQ.1)) RETURN      NP=N      MP=M      IPSYM=0      RETURN      END               SUBROUTINE NEFLD (XOB,YOB,ZOB,EX,EY,EZ)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC




























































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     NEFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTERC     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.C      COMPLEX*16 EX,EY,EZ,CUR,ACX,BCX,CCX,EXK,EYK,EZK,EXS,EYS,EZS,EXC     1,EYC,EZC,ZRATI,ZRATI2,T1,FRATI      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /ANGL/ SALP(MAXSEG)      COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),     &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)      COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,     &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,     &KSYMP,IFAR,IPERF      DIMENSION CAB(1), SAB(1), T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1),     1T2Z(1)      EQUIVALENCE (CAB,ALP), (SAB,BET)      EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON     12), (T2Z,ITAG)      EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y     1J,IND1), (T2ZJ,IND2)      EX=(0.,0.)      EY=(0.,0.)      EZ=(0.,0.)      AX=0.      IF (N.EQ.0) GO TO 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)) GO TO 1      ZP=XJ*XJ+YJ*YJ+ZJ*ZJ-ZP*ZP      XJ=BI(I)      IF (ZP.GT.0.9*XJ*XJ) GO TO 1      AX=XJ      GO TO 21     CONTINUE2     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) GO TO 18      IPR=ICON1(I)      IF (IPR) 3,8,43     IPR=-IPR      IF (-ICON1(IPR).NE.I) GO TO 9      GO TO 64     IF (IPR.NE.I) GO TO 5      IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 9      GO TO 75     IF (ICON2(IPR).NE.I) GO TO 96     XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))      IF (XI.LT.0.999999D+0) GO TO 9      IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 97     IND1=0      GO TO 108     IND1=1      GO TO 109     IND1=210    IPR=ICON2(I)      IF (IPR) 11,16,1211    IPR=-IPR      IF (-ICON2(IPR).NE.I) GO TO 17      GO TO 1412    IF (IPR.NE.I) GO TO 13      IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 17      GO TO 1513    IF (ICON1(IPR).NE.I) GO TO 1714    XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))      IF (XI.LT.0.999999D+0) GO TO 17      IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 1715    IND2=0      GO TO 1816    IND2=1      GO TO 1817    IND2=218    CONTINUE      CALL EFLD (XOB,YOB,ZOB,AX,1)      ACX=DCMPLX(AIR(I),AII(I))      BCX=DCMPLX(BIR(I),BII(I))      CCX=DCMPLX(CIR(I),CII(I))      EX=EX+EXK*ACX+EXS*BCX+EXC*CCX      EY=EY+EYK*ACX+EYS*BCX+EYC*CCX19    EZ=EZ+EZK*ACX+EZS*BCX+EZC*CCX      IF (M.EQ.0) RETURN20    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*EYS21    EZ=EZ+ACX*EZK+BCX*EZS      RETURN      END      SUBROUTINE NETWK (CM,CMB,CMC,CMD,IP,EINC)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC












































































































































































































































































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***CC     SUBROUTINE NETWK SOLVES FOR STRUCTURE CURRENTS FOR A GIVENC     EXCITATION INCLUDING THE EFFECT OF NON-RADIATING NETWORKS IFC     PRESENT.C      COMPLEX*16 CMN,RHNT,YMIT,RHS,ZPED,EINC,VSANT,VLT,CUR,VSRC,RHNX     1,VQD,VQDS,CUX,CM,CMB,CMC,CMD      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),     &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)      COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS(     130),NVQD,NSANT,NQDS      COMMON/NETCX/ZPED,PIN,PNLS,X11R(30),X11I(30),X12R(30),X12I(30),     &X22R(30),X22I(30),NTYP(30),ISEG1(30),ISEG2(30),NEQ,NPEQ,NEQ2,     &NONET,NTSOL,NPRINT,MASYM      DIMENSION EINC(1), IP(1),CM(1),CMB(1),CMC(1),CMD(1)      DIMENSION CMN(30,30), RHNT(30), IPNT(30), NTEQA(30), NTSCA(30),     &RHS(3*MAXSEG), VSRC(30), RHNX(30)      DATA NDIMN,NDIMNP/30,31/,TP/6.283185308D+0/      NEQZ2=NEQ2      IF(NEQZ2.EQ.0)NEQZ2=1      PIN=0.      PNLS=0.      NEQT=NEQ+NEQ2      IF (NTSOL.NE.0) GO TO 42      NOP=NEQ/NPEQ      IF (MASYM.EQ.0) GO TO 14CC     COMPUTE RELATIVE MATRIX ASYMMETRYC      IROW1=0      IF (NONET.EQ.0) GO TO 5      DO 4 I=1,NONET      NSEG1=ISEG1(I)      DO 3 ISC1=1,2      IF (IROW1.EQ.0) GO TO 2      DO 1 J=1,IROW1      IF (NSEG1.EQ.IPNT(J)) GO TO 31     CONTINUE2     IROW1=IROW1+1      IPNT(IROW1)=NSEG13     NSEG1=ISEG2(I)4     CONTINUE5     IF (NSANT.EQ.0) GO TO 9      DO 8 I=1,NSANT      NSEG1=ISANT(I)      IF (IROW1.EQ.0) GO TO 7      DO 6 J=1,IROW1      IF (NSEG1.EQ.IPNT(J)) GO TO 86     CONTINUE7     IROW1=IROW1+1      IPNT(IROW1)=NSEG18     CONTINUE9     IF (IROW1.LT.NDIMNP) GO TO 10      WRITE(3,59)      STOP10    IF (IROW1.LT.2) GO TO 14      DO 12 I=1,IROW1      ISC1=IPNT(I)      ASM=SI(ISC1)      DO 11 J=1,NEQT11    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) GO TO 13      ASM=PWR      NTEQ=IPNT(I)      NTSC=IPNT(J)13    CONTINUE      ASA=SQRT(ASA*2./DFLOAT(IROW1*(IROW1-1)))      WRITE(3,58)  ASM,NTEQ,NTSC,ASA14    IF (NONET.EQ.0) GO TO 48CC     SOLUTION OF NETWORK EQUATIONSC      DO 15 I=1,NDIMN      RHNX(I)=(0.,0.)      DO 15 J=1,NDIMN15    CMN(I,J)=(0.,0.)      NTEQ=0      NTSC=0CC     SORT NETWORK AND SOURCE DATA AND ASSIGN EQUATION NUMBERS TOC     SEGMENTS.C      DO 38 J=1,NONET      NSEG1=ISEG1(J)      NSEG2=ISEG2(J)      IF (NTYP(J).GT.1) GO TO 16      Y11R=X11R(J)      Y11I=X11I(J)      Y12R=X12R(J)      Y12I=X12I(J)      Y22R=X22R(J)      Y22I=X22I(J)      GO TO 1716    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) GO TO 17      Y12R=-Y12R      Y12I=-Y12I17    IF (NSANT.EQ.0) GO TO 19      DO 18 I=1,NSANT      IF (NSEG1.NE.ISANT(I)) GO TO 18      ISC1=I      GO TO 2218    CONTINUE19    ISC1=0      IF (NTEQ.EQ.0) GO TO 21      DO 20 I=1,NTEQ      IF (NSEG1.NE.NTEQA(I)) GO TO 20      IROW1=I      GO TO 2520    CONTINUE21    NTEQ=NTEQ+1      IROW1=NTEQ      NTEQA(NTEQ)=NSEG1      GO TO 2522    IF (NTSC.EQ.0) GO TO 24      DO 23 I=1,NTSC      IF (NSEG1.NE.NTSCA(I)) GO TO 23      IROW1=NDIMNP-I      GO TO 2523    CONTINUE24    NTSC=NTSC+1      IROW1=NDIMNP-NTSC      NTSCA(NTSC)=NSEG1      VSRC(NTSC)=VSANT(ISC1)25    IF (NSANT.EQ.0) GO TO 27      DO 26 I=1,NSANT      IF (NSEG2.NE.ISANT(I)) GO TO 26      ISC2=I      GO TO 3026    CONTINUE27    ISC2=0      IF (NTEQ.EQ.0) GO TO 29      DO 28 I=1,NTEQ      IF (NSEG2.NE.NTEQA(I)) GO TO 28      IROW2=I      GO TO 3328    CONTINUE29    NTEQ=NTEQ+1      IROW2=NTEQ      NTEQA(NTEQ)=NSEG2      GO TO 3330    IF (NTSC.EQ.0) GO TO 32      DO 31 I=1,NTSC      IF (NSEG2.NE.NTSCA(I)) GO TO 31      IROW2=NDIMNP-I      GO TO 3331    CONTINUE32    NTSC=NTSC+1      IROW2=NDIMNP-NTSC      NTSCA(NTSC)=NSEG2      VSRC(NTSC)=VSANT(ISC2)33    IF (NTSC+NTEQ.LT.NDIMNP) GO TO 34      WRITE(3,59)      STOPCC     FILL NETWORK EQUATION MATRIX AND RIGHT HAND SIDE VECTOR WITHC     NETWORK SHORT-CIRCUIT ADMITTANCE MATRIX COEFFICIENTS.C34    IF (ISC1.NE.0) GO TO 35      CMN(IROW1,IROW1)=CMN(IROW1,IROW1)-DCMPLX(Y11R,Y11I)*SI(NSEG1)      CMN(IROW1,IROW2)=CMN(IROW1,IROW2)-DCMPLX(Y12R,Y12I)*SI(NSEG1)      GO TO 3635    RHNX(IROW1)=RHNX(IROW1)+DCMPLX(Y11R,Y11I)*VSANT(ISC1)/WLAM      RHNX(IROW2)=RHNX(IROW2)+DCMPLX(Y12R,Y12I)*VSANT(ISC1)/WLAM36    IF (ISC2.NE.0) GO TO 37      CMN(IROW2,IROW2)=CMN(IROW2,IROW2)-DCMPLX(Y22R,Y22I)*SI(NSEG2)      CMN(IROW2,IROW1)=CMN(IROW2,IROW1)-DCMPLX(Y12R,Y12I)*SI(NSEG2)      GO TO 3837    RHNX(IROW1)=RHNX(IROW1)+DCMPLX(Y12R,Y12I)*VSANT(ISC2)/WLAM      RHNX(IROW2)=RHNX(IROW2)+DCMPLX(Y22R,Y22I)*VSANT(ISC2)/WLAM38    CONTINUECC     ADD INTERACTION MATRIX ADMITTANCE ELEMENTS TO NETWORK EQUATIONC     MATRIXC      DO 41 I=1,NTEQ      DO 39 J=1,NEQT39    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)41    CONTINUECC     FACTOR NETWORK EQUATION MATRIXC      CALL FACTR (NTEQ,CMN,IPNT,NDIMN)CC     ADD TO NETWORK EQUATION RIGHT HAND SIDE THE TERMS DUE TO ELEMENTC     INTERACTIONSC42    IF (NONET.EQ.0) GO TO 48      DO 43 I=1,NEQT43    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)44    RHNT(I)=RHNX(I)+RHS(IROW1)CC     SOLVE NETWORK EQUATIONSC      CALL SOLVE (NTEQ,CMN,IPNT,RHNT,NDIMN)CC     ADD FIELDS DUE TO NETWORK VOLTAGES TO ELECTRIC FIELDS APPLIED TOC     STRUCTURE AND SOLVE FOR INDUCED CURRENTC      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(3,61)      IF (NPRINT.EQ.0) WRITE(3,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*DREAL(VLT*DCONJG(CUX))      PNLS=PNLS-PWR46    IF (NPRINT.EQ.0) WRITE(3,62)  IROW2,IROW1,VLT,CUX,ZPED,YMIT,PWR      IF (NTSC.EQ.0) GO TO 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*DREAL(VLT*DCONJG(CUX))      PNLS=PNLS-PWR47    IF (NPRINT.EQ.0) WRITE(3,62)  IROW2,IROW1,VLT,CUX,ZPED,YMIT,PWR      GO TO 49CC     SOLVE FOR CURRENTS WHEN NO NETWORKS ARE PRESENTC48    CALL SOLGF (CM,CMB,CMC,CMD,EINC,IP,NP,N1,N,MP,M1,M,NEQ,NEQ2,NEQZ2)      CALL CABC (EINC)      NTSC=049    IF (NSANT+NVQD.EQ.0) RETURN      WRITE(3,63)      WRITE(3,60)      IF (NSANT.EQ.0) GO TO 56      DO 55 I=1,NSANT      ISC1=ISANT(I)      VLT=VSANT(I)      IF (NTSC.EQ.0) GO TO 51      DO 50 J=1,NTSC      IF (NTSCA(J).EQ.ISC1) GO TO 5250    CONTINUE51    CUX=EINC(ISC1)*WLAM      IROW1=0      GO TO 5452    IROW1=NDIMNP-J      CUX=RHNX(IROW1)      DO 53 J=1,NTEQ53    CUX=CUX-CMN(J,IROW1)*RHNT(J)      CUX=(EINC(ISC1)+CUX)*WLAM54    YMIT=CUX/VLT      ZPED=VLT/CUX      PWR=.5*DREAL(VLT*DCONJG(CUX))      PIN=PIN+PWR      IF (IROW1.NE.0) PNLS=PNLS+PWR      IROW2=ITAG(ISC1)55    WRITE(3,62)  IROW2,ISC1,VLT,CUX,ZPED,YMIT,PWR56    IF (NVQD.EQ.0) RETURN      DO 57 I=1,NVQD      ISC1=IVQD(I)      VLT=VQD(I)      CUX=DCMPLX(AIR(ISC1),AII(ISC1))      YMIT=DCMPLX(BIR(ISC1),BII(ISC1))      ZPED=DCMPLX(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*DREAL(VLT*DCONJG(CUX))      PIN=PIN+PWR      IROW2=ITAG(ISC1)57    WRITE(3,64)  IROW2,ISC1,VLT,CUX,ZPED,YMIT,PWR      RETURNC58    FORMAT (///,3X,47HMAXIMUM RELATIVE ASYMMETRY OF THE DRIVING POINT,     121H ADMITTANCE MATRIX IS,1P,E10.3,13H FOR SEGMENTS,I5,4H AND,I5,/,     23X,25HRMS RELATIVE ASYMMETRY IS,E10.3)59    FORMAT (1X,44HERROR - - NETWORK ARRAY DIMENSIONS TOO SMALL)60    FORMAT (/,3X,3HTAG,3X,4HSEG.,4X,15HVOLTAGE (VOLTS),9X,14HCURRENT (     1AMPS),9X,16HIMPEDANCE (OHMS),8X,17HADMITTANCE (MHOS),6X,5HPOWER,/,     23X,3HNO.,3X,3HNO.,4X,4HREAL,8X,5HIMAG.,3(7X,4HREAL,8X,5HIMAG.),5X,     37H(WATTS))61    FORMAT (///,27X,66H- - - STRUCTURE EXCITATION DATA AT NETWORK CONN     1ECTION POINTS - - -)62    FORMAT (2(1X,I5),1P,9E12.5)63    FORMAT (///,42X,36H- - - ANTENNA INPUT PARAMETERS - - -)64    FORMAT (1X,I5,2H *,I4,1P,9E12.5)      END      SUBROUTINE NFPATC ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC


































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***C     COMPUTE NEAR E OR H FIELDS OVER A RANGE OF POINTS      COMPLEX*16 EX,EY,EZ      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON/FPAT/THETS,PHIS,DTH,DPH,RFLD,GNOR,CLT,CHT,EPSR2,SIG2,     &XPR6,PINR,PNLR,PLOSS,XNR,YNR,ZNR,DXNR,DYNR,DZNR,NTH,NPH,IPD,IAVP,     &INOR,IAX,IXTYP,NEAR,NFEH,NRX,NRY,NRZC***      COMMON /PLOT/ IPLP1,IPLP2,IPLP3,IPLP4C***      DATA TA/1.745329252D-02/      IF (NFEH.EQ.1) GO TO 1      WRITE(3,10)      GO TO 21     WRITE(3,12)2     ZNRT=ZNR-DZNR      DO 9 I=1,NRZ      ZNRT=ZNRT+DZNR      IF (NEAR.EQ.0) GO TO 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) GO TO 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) GO TO 5      XOB=XNRT*STH*CPH      YOB=XNRT*STH*SPH      ZOB=XNRT*CTH      GO TO 65     XOB=XNRT      YOB=YNRT      ZOB=ZNRT6     TMP1=XOB/WLAM      TMP2=YOB/WLAM      TMP3=ZOB/WLAM      IF (NFEH.EQ.1) GO TO 7      CALL NEFLD (TMP1,TMP2,TMP3,EX,EY,EZ)      GO TO 87     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)      WRITE(3,11)  XOB,YOB,ZOB,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6C***      IF(IPLP1 .NE. 2) GO TO 9      GO TO (14,15,16),IPLP414    XXX=XOB      GO TO 1715    XXX=YOB      GO TO 1716    XXX=ZOB17    CONTINUE      IF(IPLP2 .NE. 2) GO TO 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      GO TO 913    IF(IPLP2 .NE. 1) GO TO 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      IF(IPLP3 .EQ. 4) WRITE(8,*) XXX,EX,EY,EZC***9     CONTINUE      RETURNC10    FORMAT (///,35X,32H- - - NEAR ELECTRIC FIELDS - - -,//,12X,14H-  L     1OCATION  -,21X,8H-  EX  -,15X,8H-  EY  -,15X,8H-  EZ  -,/,8X,1HX,1     20X,1HY,10X,1HZ,10X,9HMAGNITUDE,3X,5HPHASE,6X,9HMAGNITUDE,3X,5HPHAS     3E,6X,9HMAGNITUDE,3X,5HPHASE,/,6X,6HMETERS,5X,6HMETERS,5X,6HMETERS,     48X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3     5X,7HDEGREES)11    FORMAT (2X,3(2X,F9.4),1X,3(3X,1P,E11.4,2X,0P,F7.2))12    FORMAT (///,35X,32H- - - NEAR MAGNETIC FIELDS - - -,//,12X,14H-  L     1OCATION  -,21X,8H-  HX  -,15X,8H-  HY  -,15X,8H-  HZ  -,/,8X,1HX,1     20X,1HY,10X,1HZ,10X,9HMAGNITUDE,3X,5HPHASE,6X,9HMAGNITUDE,3X,5HPHAS     3E,6X,9HMAGNITUDE,3X,5HPHASE,/,6X,6HMETERS,5X,6HMETERS,5X,6HMETERS,     49X,6HAMPS/M,3X,7HDEGREES,7X,6HAMPS/M,3X,7HDEGREES,7X,6HAMPS/M,3X,7     5HDEGREES)      END      SUBROUTINE NHFLD (XOB,YOB,ZOB,HX,HY,HZ)CC     NHFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTERC     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.C      INCLUDE 'NEC2DPAR.INC












































































































'      IMPLICIT REAL*8(A-H,O-Z)      COMPLEX*16 HX,HY,HZ,CUR,ACX,BCX,CCX,EXK,EYK,EZK,EXS,EYS,EZS,EXC,     &EYC,EZCC***************************************      COMPLEX*16 ZRATI,ZRATI2,FRATI,T1,CON      COMPLEX*16 EXPX,EXMX,EXPY,EXMY,EXPZ,EXMZ      COMPLEX*16 EYPX,EYMX,EYPY,EYMY,EYPZ,EYMZ      COMPLEX*16 EZPX,EZMX,EZPY,EZMY,EZPZ,EZMZ      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,     &KSYMP,IFAR,IPERFC***************************************      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /ANGL/ SALP(MAXSEG)      COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),     &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)      COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,     &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND      DIMENSION CAB(1), SAB(1)      DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), XS(1), Y     1S(1), ZS(1)      EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON     12), (T2Z,ITAG), (XS,X), (YS,Y), (ZS,Z)      EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y     1J,IND1), (T2ZJ,IND2)      EQUIVALENCE (CAB,ALP), (SAB,BET)C***************************************      IF (IPERF.EQ.2) GO TO 6C***************************************      HX=(0.,0.)      HY=(0.,0.)      HZ=(0.,0.)      AX=0.      IF (N.EQ.0) GO TO 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)) GO TO 1      ZP=XJ*XJ+YJ*YJ+ZJ*ZJ-ZP*ZP      XJ=BI(I)      IF (ZP.GT.0.9*XJ*XJ) GO TO 1      AX=XJ      GO TO 21     CONTINUE2     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=DCMPLX(AIR(I),AII(I))      BCX=DCMPLX(BIR(I),BII(I))      CCX=DCMPLX(CIR(I),CII(I))      HX=HX+EXK*ACX+EXS*BCX+EXC*CCX      HY=HY+EYK*ACX+EYS*BCX+EYC*CCX3     HZ=HZ+EZK*ACX+EZS*BCX+EZC*CCX      IF (M.EQ.0) RETURN4     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*EYS5     HZ=HZ+ACX*EZK+BCX*EZS      RETURNCC     GET H BY FINITE DIFFERENCE OF E FOR SOMMERFELD GROUNDC     CON=j/(2*pi*eta)C     DELT is the increment for getting central differencesC6     DELT=1.E-3      CON=(0.,4.2246E-4)      CALL NEFLD (XOB+DELT,YOB,ZOB,EXPX,EYPX,EZPX)      CALL NEFLD (XOB-DELT,YOB,ZOB,EXMX,EYMX,EZMX)      CALL NEFLD (XOB,YOB+DELT,ZOB,EXPY,EYPY,EZPY)      CALL NEFLD (XOB,YOB-DELT,ZOB,EXMY,EYMY,EZMY)      CALL NEFLD (XOB,YOB,ZOB+DELT,EXPZ,EYPZ,EZPZ)      CALL NEFLD (XOB,YOB,ZOB-DELT,EXMZ,EYMZ,EZMZ)      HX=CON*(EZPY-EZMY-EYPZ+EYMZ)/(2.*DELT)      HY=CON*(EXPZ-EXMZ-EZPX+EZMX)/(2.*DELT)      HZ=CON*(EYPX-EYMX-EXPY+EXMY)/(2.*DELT)      RETURN      END      SUBROUTINE PATCH (NX,NY,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC










































































































































































































































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***C     PATCH GENERATES AND MODIFIES PATCH GEOMETRY DATA      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /ANGL/ SALP(MAXSEG)      DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)      EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON     12), (T2Z,ITAG)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 WITHC     NX BY NY RECTANGULAR PATCHES.      M=M+1      MI=LD+1-M      NTP=NY      IF (NX.GT.0) NTP=2      IF (NTP.GT.1) GO TO 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) GO TO 1      T1X(MI)=-YNV/XA      T1Y(MI)=XNV/XA      T1Z(MI)=0.      GO TO 61     T1X(MI)=1.      T1Y(MI)=0.      T1Z(MI)=0.      GO TO 62     S1X=X2-X1      S1Y=Y2-Y1      S1Z=Z2-Z1      S2X=X3-X2      S2Y=Y3-Y2      S2Z=Z3-Z2      IF (NX.EQ.0) GO TO 3      S1X=S1X/NX      S1Y=S1Y/NX      S1Z=S1Z/NX      S2X=S2X/NY      S2Y=S2Y/NY      S2Z=S2Z/NY3     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) GO TO 4      X(MI)=X1+.5*(S1X+S2X)      Y(MI)=Y1+.5*(S1Y+S2Y)      Z(MI)=Z1+.5*(S1Z+S2Z)      BI(MI)=XA      GO TO 64     IF (NTP.EQ.4) GO TO 5      X(MI)=(X1+X2+X3)/3.      Y(MI)=(Y1+Y2+Y3)/3.      Z(MI)=(Z1+Z2+Z3)/3.      BI(MI)=.5*XA      GO TO 65     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) GO TO 6      WRITE(3,14)      STOP6     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) GO TO 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)=YT7     T2Z(MI)=ZT8     IPSYM=0      NP=N      MP=M      RETURNC     DIVIDE PATCH FOR WIRE CONNECTION      ENTRY SUBPH (NX,NY,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4)      IF (NY.GT.0) GO TO 10      IF (NX.EQ.M) GO TO 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) GO TO 11      MIA=MI      GO TO 1211    M=M+1      MP=MP+1      MIA=LD+1-M12    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-113    CONTINUE      M=M+3      IF (NX.LE.MP) MP=MP+3      IF (NY.GT.0) Z(MI)=10000.      RETURNC14    FORMAT (62H ERROR -- CORNERS OF QUADRILATERAL PATCH DO NOT LIE IN      1A PLANE)      END      SUBROUTINE PCINT (XI,YI,ZI,CABI,SABI,SALPI,E)C ***C     DOUBLE PRECISION 6/4/85C      IMPLICIT REAL*8(A-H,O-Z)C ***C     INTEGRATE OVER PATCHES AT WIRE CONNECTION POINT      COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,E,E1,E2,E3,E4,E5     1,E6,E7,E8,E9      COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,     &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND      DIMENSION E(9)      EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y     1J,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*G41     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      SUBROUTINE PRNT(IN1,IN2,IN3,FL1,FL2,FL3,FL4,FL5,FL6,CTYPE)CC     Purpose:C     PRNT prints the input data for impedance loading, inserting blanksC     for numbers that are zero.CC     INPUT:C     IN1-3 = INTEGER VALUES TO BE PRINTEDC     FL1-6 = REAL VALUES TO BE PRINTEDC     CTYPE = CHARACTER STRING TO BE PRINTEDC      IMPLICIT REAL*8(A-H,O-Z)      CHARACTER CTYPE*(*), CINT(3)*5, CFLT(6)*13C      DO 1 I=1,31     CINT(I)='     

'      IF(IN1.EQ.0.AND.IN2.EQ.0.AND.IN3.EQ.0)THEN         CINT(1)='  ALL






'      ELSE         IF(IN1.NE.0)WRITE(CINT(1),90)IN1         IF(IN2.NE.0)WRITE(CINT(2),90)IN2         IF(IN3.NE.0)WRITE(CINT(3),90)IN3      END IF      DO 2 I=1,62     CFLT(I)='     

















'      IF(ABS(FL1).GT.1.E-30)WRITE(CFLT(1),91)FL1      IF(ABS(FL2).GT.1.E-30)WRITE(CFLT(2),91)FL2      IF(ABS(FL3).GT.1.E-30)WRITE(CFLT(3),91)FL3      IF(ABS(FL4).GT.1.E-30)WRITE(CFLT(4),91)FL4      IF(ABS(FL5).GT.1.E-30)WRITE(CFLT(5),91)FL5      IF(ABS(FL6).GT.1.E-30)WRITE(CFLT(6),91)FL6      WRITE(3,92)(CINT(I),I=1,3),(CFLT(I),I=1,6),CTYPE      RETURNC90    FORMAT(I5)91    FORMAT(1P,E13.4)92    FORMAT(/,3X,3A,3X,6A,3X,A)      END      SUBROUTINE QDSRC (IS,V,E)C ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC






























































































































'      IMPLICIT REAL*8(A-H,O-Z)C ***C     FILL INCIDENT FIELD ARRAY FOR CHARGE DISCONTINUITY VOLTAGE SOURCE      COMPLEX*16 VQDS,CURD,CCJ,V,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC     1,ETK,ETS,ETC,VSANT,VQD,E,ZARRAY      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS(     130),NVQD,NSANT,NQDS      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP     1CON(10),NPCON      COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,     &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND      COMMON /ANGL/ SALP(MAXSEG)      COMMON /ZLOAD/ ZARRAY(MAXSEG),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,ICON     12), (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)*SI     1N(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) GO TO 16      IPR=ICON1(J)      IF (IPR) 1,6,21     IPR=-IPR      IF (-ICON1(IPR).NE.J) GO TO 7      GO TO 42     IF (IPR.NE.J) GO TO 3      IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 7      GO TO 53     IF (ICON2(IPR).NE.J) GO TO 74     XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))      IF (XI.LT.0.999999D+0) GO TO 7      IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 75     IND1=0      GO TO 86     IND1=1      GO TO 87     IND1=28     IPR=ICON2(J)      IF (IPR) 9,14,109     IPR=-IPR      IF (-ICON2(IPR).NE.J) GO TO 15      GO TO 1210    IF (IPR.NE.J) GO TO 11      IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 15      GO TO 1311    IF (ICON1(IPR).NE.J) GO TO 1512    XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))      IF (XI.LT.0.999999D+0) GO TO 15      IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 1513    IND2=0      GO TO 1614    IND2=1      GO TO 1615    IND2=216    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*SALPI17    E(I)=E(I)-(ETK*AX(JX)+ETS*BX(JX)+ETC*CX(JX))*CURD      IF (M.EQ.0) GO TO 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.D0)      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*TZ18    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(     1JX))20    CONTINUE      RETURN      END      SUBROUTINE RDPATC ***C     DOUBLE PRECISION 6/4/85C      INCLUDE 'NEC2DPAR.INC






































































































































































































































































































'      PARAMETER(NORMAX=4*MAXSEG)      IMPLICIT REAL*8(A-H,O-Z)C ***C     COMPUTE RADIATION PATTERN, GAIN, NORMALIZED GAIN      REAL*8 IGNTP,IGAX,IGTP,HCIR,HBLK,HPOL,HCLIF,ISENSC     INTEGER HPOL,HBLK,HCIR,HCLIF      COMPLEX*16 ETH,EPH,ERD,ZRATI,ZRATI2,T1,FRATI      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM      COMMON/SAVE/EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(2*MAXSEG),KCOM      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,     &KSYMP,IFAR,IPERF      COMMON/FPAT/THETS,PHIS,DTH,DPH,RFLD,GNOR,CLT,CHT,EPSR2,SIG2,     &XPR6,PINR,PNLR,PLOSS,XNR,YNR,ZNR,DXNR,DYNR,DZNR,NTH,NPH,IPD,IAVP,     &INOR,IAX,IXTYP,NEAR,NFEH,NRX,NRY,NRZ      COMMON /SCRATM/ GAIN(NORMAX)C***      COMMON /PLOT/ IPLP1,IPLP2,IPLP3,IPLP4C***      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 ,6     1H HORIZ,6HONTAL ,6H      ,6HTOTAL /      DATA PI,TA,TD/3.141592654D+0,1.745329252D-02,57.29577951D+0/      IF (IFAR.LT.2) GO TO 2      WRITE(3,35)      IF (IFAR.LE.3) GO TO 1      WRITE(3,36)  NRADL,SCRWLT,SCRWRT      IF (IFAR.EQ.4) GO TO 21     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./DCMPLX(EPSR2,-SIG2*WLAM*59.96))      WRITE(3,37)  HCLIF,CLT,CHT,EPSR2,SIG22     IF (IFAR.NE.1) GO TO 3      WRITE(3,41)      GO TO 53     I=2*IPD+1      J=I+1      ITMP1=2*IAX+1      ITMP2=ITMP1+1      WRITE(3,38)      IF (RFLD.LT.1.D-20) GO TO 4      EXRM=1./RFLD      EXRA=RFLD/WLAM      EXRA=-360.*(EXRA-AINT(EXRA))      WRITE(3,39)  RFLD,EXRM,EXRA4     WRITE(3,40)  IGTP(I),IGTP(J),IGAX(ITMP1),IGAX(ITMP2)5     IF (IXTYP.EQ.0.OR.IXTYP.EQ.5) GO TO 7      IF (IXTYP.EQ.4) GO TO 6      PRAD=0.      GCON=4.*PI/(1.+XPR6*XPR6)      GCOP=GCON      GO TO 86     PINR=394.51*XPR6*XPR6*WLAM*WLAM7     GCOP=WLAM*WLAM*2.*PI/(376.73*PINR)      PRAD=PINR-PLOSS-PNLR      GCON=GCOP      IF (IPD.NE.0) GCON=GCON*PINR/PRAD8     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) GO TO 29      THA=THET*TA      IF (IFAR.EQ.1) GO TO 9      CALL FFLD (THA,PHA,ETH,EPH)      GO TO 109     CALL GFLD (RFLD/WLAM,PHA,THET/WLAM,ETH,EPH,ERD,ZRATI,KSYMP)      ERDM=ABS(ERD)      ERDA=CANG(ERD)10    ETHM2=DREAL(ETH*DCONJG(ETH))      ETHM=SQRT(ETHM2)      ETHA=CANG(ETH)      EPHM2=DREAL(EPH*DCONJG(EPH))      EPHM=SQRT(EPHM2)      EPHA=CANG(EPH)      IF (IFAR.EQ.1) GO TO 28C     ELLIPTICAL POLARIZATION CALC.      IF (ETHM2.GT.1.D-20.OR.EPHM2.GT.1.D-20) GO TO 11      TILTA=0.      EMAJR2=0.      EMINR2=0.      AXRAT=0.      ISENS=HBLK      GO TO 1611    DFAZ=EPHA-ETHA      IF (EPHA.LT.0.) GO TO 12      DFAZ2=DFAZ-360.      GO TO 1312    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) GO TO 14      ISENS=HPOL(1)      GO TO 1614    IF (DFAZ.GT.0.) GO TO 15      ISENS=HPOL(2)      GO TO 1615    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) GO TO 23      I=I+1      IF (I.GT.NORMAX) GO TO 23      GO TO (17,18,19,20,21), INOR17    TSTOR1=GNMJ      GO TO 2218    TSTOR1=GNMN      GO TO 2219    TSTOR1=GNV      GO TO 2220    TSTOR1=GNH      GO TO 2221    TSTOR1=GTOT22    GAIN(I)=TSTOR1      IF (TSTOR1.GT.GMAX) GMAX=TSTOR123    IF (IAVP.EQ.0) GO TO 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) GO TO 2924    IF (IAX.EQ.1) GO TO 25      TMP5=GNMJ      TMP6=GNMN      GO TO 2625    TMP5=GNV      TMP6=GNH26    ETHM=ETHM*WLAM      EPHM=EPHM*WLAM      IF (RFLD.LT.1.D-20) GO TO 27      ETHM=ETHM*EXRM      ETHA=ETHA+EXRA      EPHM=EPHM*EXRM      EPHA=EPHA+EXRA27    WRITE(3,42)  THET,PHI,TMP5,TMP6,GTOT,AXRAT,TILTA,ISENS,ETHM,ETHA     1,EPHM,EPHAC      GO TO 29C***C28    WRITE(3,43)  RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA      IF(IPLP1 .NE. 3) GO TO 299      IF(IPLP3 .EQ. 0) GO TO 290      IF(IPLP2 .EQ. 1 .AND. IPLP3 .EQ. 1)     1WRITE(8,*) THET,ETHM,ETHA      IF(IPLP2 .EQ. 1 .AND. IPLP3 .EQ. 2)     1WRITE(8,*) THET,EPHM,EPHA      IF(IPLP2 .EQ. 2 .AND. IPLP3 .EQ. 1)     1WRITE(8,*) PHI,ETHM,ETHA      IF(IPLP2 .EQ. 2 .AND. IPLP3 .EQ. 2)     1WRITE(8,*) PHI,EPHM,EPHA      IF(IPLP4 .EQ. 0) GO TO 299290   IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 1)     1WRITE(8,*) THET,TMP5      IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 2)     1WRITE(8,*) THET,TMP6      IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 3)     1WRITE(8,*) THET,GTOT      IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 1)     1WRITE(8,*) PHI,TMP5      IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 2)     1WRITE(8,*) PHI,TMP6      IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 3)     1WRITE(8,*) PHI,GTOT      GO TO 29928    WRITE(3,43)  RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA299   CONTINUEC***29    CONTINUE      IF (IAVP.EQ.0) GO TO 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(3,44)  PINT,TMP330    IF (INOR.EQ.0) GO TO 34      IF (ABS(GNOR).GT.1.D-20) GMAX=GNOR      ITMP1=(INOR-1)*2+1      ITMP2=ITMP1+1      WRITE(3,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) GO TO 32      TSTOR2=GAIN(ITMP3)-GMAX      PINT=GAIN(ITMP4)-GMAX31    WRITE(3,46)  TMP1,TMP2,TSTOR1,TMP3,TMP4,TSTOR2,TMP5,TMP6,PINT      GO TO 3432    IF (ITMP2.EQ.2) GO TO 33      TSTOR2=GAIN(ITMP3)-GMAX      WRITE(3,46)  TMP1,TMP2,TSTOR1,TMP3,TMP4,TSTOR2      GO TO 3433    WRITE(3,46)  TMP1,TMP2,TSTOR134    RETURNC35    FORMAT (///,31X,39H- - - FAR FIELD GROUND PARAMETERS - - -,//)36    FORMAT (40X,25HRADIAL WIRE GROUND SCREEN,/,40X,I5,6H WIRES,/,40X,1     12HWIRE LENGTH=,F8.2,7H METERS,/,40X,12HWIRE RADIUS=,1P,E10.3,     27H METERS)37    FORMAT (40X,A6,6H CLIFF,/,40X,14HEDGE DISTANCE=,F9.2,7H METERS,/,4     10X,7HHEIGHT=,F8.2,7H METERS,/,40X,15HSECOND MEDIUM -,/,40X,27HRELA     2TIVE DIELECTRIC CONST.=,F7.3,/,40X,13HCONDUCTIVITY=,1P,E10.3,     35H MHOS)38    FORMAT (///,48X,30H- - - RADIATION PATTERNS - - -)39    FORMAT (54X,6HRANGE=,1P,E13.6,7H METERS,/,54X,12HEXP(-JKR)/R=,     1E12.5,9H AT PHASE,0P,F7.2,8H DEGREES,/)40    FORMAT (/,2X,14H- - ANGLES - -,7X,2A6,7HGAINS -,7X,24H- - - POLARI     1ZATION - - -,4X,20H- - - E(THETA) - - -,4X,18H- - - E(PHI) - - -,     2/,2X,5HTHETA,5X,3HPHI,7X,A6,2X,A6,3X,5HTOTAL,6X,5HAXIAL,5X,4HTILT,     33X,5HSENSE,2(5X,9HMAGNITUDE,4X,6HPHASE ),/,2(1X,7HDEGREES,1X),3(     46X,2HDB),8X,5HRATIO,5X,4HDEG.,8X,2(6X,7HVOLTS/M,4X,7HDEGREES))41    FORMAT (///,28X,40H - - - RADIATED FIELDS NEAR GROUND - - -,//,8X,     120H- - - LOCATION - - -,10X,16H- - E(THETA) - -,8X,14H- - E(PHI) -     2 -,8X,17H- - E(RADIAL) - -,/,7X,3HRHO,6X,3HPHI,9X,1HZ,12X,3HMAG,6X     3,5HPHASE,9X,3HMAG,6X,5HPHASE,9X,3HMAG,6X,5HPHASE,/,5X,6HMETERS,3X,     47HDEGREES,4X,6HMETERS,8X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3X,7H     5DEGREES,6X,7HVOLTS/M,3X,7HDEGREES,/)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,19HAVERAGE POWER GAIN=,1P,E12.5,7X, 31HSOLID ANGLE U     1SED IN AVERAGING=(,0P,F7.4,16H)*PI STERADIANS.,//)45    FORMAT (//,37X,31H- - - - NORMALIZED GAIN - - - -,//,37X,2A6,4HGAI     1N,/,38X,22HNORMALIZATION FACTOR =,F9.2,3H DB,//,3(4X,14H- - ANGLES     2 - -,6X,4HGAIN,7X),/,3(4X,5HTHETA,5X,3HPHI,8X,2HDB,8X),/,3(3X,7HDE     3GREES,2X,7HDEGREES,16X))46    FORMAT (3(1X,2F9.2,1X,F9.2,6X))      END      SUBROUTINE READGM(INUNIT,CODE,I1,I2,R1,R2,R3,R4,R5,R6,R7)CC  READGM reads a geometry record and parses it.CC  *****  Passed variablesC     CODE        two letter mnemonic codeC     I1 - I2     integer values from recordC     R1 - R7     real values from recordC      IMPLICIT REAL*8(A-H,O-Z)      CHARACTER*(*) CODE      DIMENSION INTVAL(2),REAVAL(7)CC  Call the routine to read the record and parse it.C      CALL PARSIT(INUNIT,2,7,CODE,INTVAL,REAVAL,IEOF)CC  Set the return variables to the buffer array elements.C      IF(IEOF.LT.0)CODE='GE
























'      I1=INTVAL(1)      I2=INTVAL(2)      R1=REAVAL(1)      R2=REAVAL(2)      R3=REAVAL(3)      R4=REAVAL(4)      R5=REAVAL(5)      R6=REAVAL(6)      R7=REAVAL(7)      RETURN      END      SUBROUTINE READMN(INUNIT,CODE,I1,I2,I3,I4,F1,F2,F3,F4,F5,F6)CC  READMN reads a control record and parses it.C      IMPLICIT REAL*8(A-H,O-Z)      CHARACTER*(*) CODE      DIMENSION INTVAL(4),REAVAL(6)CC  Call the routine to read the record and parse it.C      CALL PARSIT(INUNIT,4,6,CODE,INTVAL,REAVAL,IEOF)CC  Set the return variables to the buffer array elements.      IF(IEOF.LT.0)CODE='EN




































































'      I1=INTVAL(1)      I2=INTVAL(2)      I3=INTVAL(3)      I4=INTVAL(4)      F1=REAVAL(1)      F2=REAVAL(2)      F3=REAVAL(3)      F4=REAVAL(4)      F5=REAVAL(5)      F6=REAVAL(6)      RETURN      END      SUBROUTINE PARSIT(INUNIT,MAXINT,MAXREA,CMND,INTFLD,REAFLD,IEOF)C  UPDATED:  21 July 87C  Called by:   READGM    READMNC  PARSIT reads an input record and parses it.C  *****  Passed variablesC     MAXINT     total number of integers in recordC     MAXREA     total number of real values in recordC     CMND       two letter mnemonic codeC     INTFLD     integer values from recordC     REAFLD     real values from recordC  *****  Internal VariablesC     BGNFLD     list of starting indicesC     BUFFER     text bufferC     ENDFLD     list of ending indicesC     FLDTRM     flag to indicate that pointer is in field positionC     REC        input line as readC     TOTCOL     total number of columns in RECC     TOTFLD     number of numeric fields      IMPLICIT REAL*8(A-H,O-Z)      CHARACTER  CMND*2, BUFFER*20, REC*80      INTEGER    INTFLD(MAXINT)      INTEGER    BGNFLD(12), ENDFLD(12), TOTCOL, TOTFLD      LOGICAL    FLDTRM      DIMENSION  REAFLD(MAXREA)C      READ(INUNIT, 8000, IOSTAT=IEOF) REC      CALL UPCASE( REC, REC, TOTCOL )CC  Store opcode and clear field arrays.C      CMND= REC(1:2)      DO 3000 I=1,MAXINT           INTFLD(I)= 0 3000 CONTINUE      DO 3010 I=1,MAXREA           REAFLD(I)= 0.0 3010 CONTINUE      DO 3020 I=1,12           BGNFLD(I)= 0           ENDFLD(I)= 0 3020 CONTINUECC  Find the beginning and ending of each field as well as the total number ofC  fields.C      TOTFLD= 0      FLDTRM= .FALSE.      LAST= MAXREA + MAXINT      DO 4000 J=3,TOTCOL           K= ICHAR( REC(J:J) )CC  Check for end of line comment (`!').  This is a new modification to allow
C  VAX-like comments at the end of data records, i.e.
C       GW 1 7 0 0 0 0 0 .5 .0001 ! DIPOLE WIRE
C       GE ! END OF GEOMETRY
C
      IF (K .EQ. 33) THEN
         IF (FLDTRM) ENDFLD(TOTFLD)= J - 1
         GO TO 5000
C
C  Set the ending index when the character is a comma or space and the pointer
C  is in a field position (FLDTRM = .TRUE.).
C
          ELSE IF (K .EQ. 32  .OR.  K .EQ. 44) THEN
             IF (FLDTRM) THEN
                ENDFLD(TOTFLD)= J - 1
                FLDTRM= .FALSE.
             ENDIF
C
C  Set the beginning index when the character is not a comma or space and the
C  pointer is not currently in a field position (FLDTRM = .FALSE).
C
          ELSE IF (.NOT. FLDTRM) THEN
              TOTFLD= TOTFLD + 1
              FLDTRM= .TRUE.
              BGNFLD(TOTFLD)= J
          ENDIF
 4000   CONTINUE
        IF (FLDTRM) ENDFLD(TOTFLD)= TOTCOL

C  Check to see if the total number of value fields is within the precribed
C  limits.

 5000   IF (TOTFLD .EQ. 0) THEN
             RETURN
        ELSE IF (TOTFLD .GT. LAST) THEN
             WRITE(3, 8001 )
             GOTO 9010
        ENDIF
        J= MIN( TOTFLD, MAXINT )

C  Parse out integer values and store into integer buffer array.

        DO 5090 I=1,J
             LENGTH= ENDFLD(I) - BGNFLD(I) + 1
             BUFFER= REC(BGNFLD(I):ENDFLD(I))
             IND= INDEX( BUFFER(1:LENGTH), '.' )
             IF (IND .GT. 0  .AND.  IND .LT. LENGTH) GO TO 9000
             IF (IND .EQ. LENGTH) LENGTH= LENGTH - 1
             READ( BUFFER(1:LENGTH), *, ERR=9000 ) INTFLD(I)
 5090   CONTINUE

C  Parse out real values and store into real buffer array.

        IF (TOTFLD .GT. MAXINT) THEN
             J= MAXINT + 1
             DO 6000 I=J,TOTFLD
                  LENGTH= ENDFLD(I) - BGNFLD(I) + 1
                  BUFFER= REC(BGNFLD(I):ENDFLD(I))
                  IND= INDEX( BUFFER(1:LENGTH), '.' )
                  IF (IND .EQ. 0) THEN
                       INDE= INDEX( BUFFER(1:LENGTH), 'E' )
                       LENGTH= LENGTH + 1
                       IF (INDE .EQ. 0) THEN
                            BUFFER(LENGTH:LENGTH)= '.'
                       ELSE
                            BUFFER= BUFFER(1:INDE-1)//'.'//
     &                               BUFFER(INDE:LENGTH-1)
                       ENDIF
                  ENDIF
                  READ( BUFFER(1:LENGTH), *, ERR=9000 ) REAFLD(I-MAXINT)
 6000        CONTINUE
        ENDIF
        RETURN

C  Print out text of record line when error occurs.

 9000   IF (I .LE. MAXINT) THEN
             WRITE(3, 8002 ) I
        ELSE
             I= I - MAXINT
             WRITE(3, 8003 ) I
        ENDIF
 9010   WRITE(3, 8004 ) REC
        STOP 'CARD ERROR'
C
C  Input formats and output messages.
C
 8000   FORMAT (A80)
 8001   FORMAT (//,' ***** CARD ERROR - TOO MANY FIELDS IN RECORD')
 8002   FORMAT (//,' ***** CARD ERROR - INVALID NUMBER AT INTEGER',
     &          ' POSITION ',I1)
 8003   FORMAT (//,' ***** CARD ERROR - INVALID NUMBER AT REAL',
     &          ' POSITION ',I1)
 8004   FORMAT (' ***** TEXT -->  ',A80)
        END
        SUBROUTINE UPCASE( INTEXT, OUTTXT, LENGTH )
C
C  UPCASE finds the length of INTEXT and converts it to upper case.
C
        CHARACTER *(*) INTEXT, OUTTXT
C
C
        LENGTH = LEN( INTEXT )
        DO 3000 I=1,LENGTH
             J  = ICHAR( INTEXT(I:I) )
             IF (J .GE. 96) J = J - 32
             OUTTXT(I:I) = CHAR( J )
 3000   CONTINUE
        RETURN
        END
      SUBROUTINE REBLK (B,BX,NB,NBX,N2C)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C     REBLOCK ARRAY B IN N.G.F. SOLUTION FROM BLOCKS OF ROWS ON TAPE14
C     TO BLOCKS OF COLUMNS ON TAPE16
      COMPLEX*16 B,BX
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
     1CASX,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
      SUBROUTINE REFLC (IX,IY,IZ,ITX,NOP)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     REFLC REFLECTS PARTIAL STRUCTURE ALONG X,Y, OR Z AXES OR ROTATES
C     STRUCTURE TO COMPLETE A SYMMETRIC STRUCTURE.
C
      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM
      COMMON /ANGL/ SALP(MAXSEG)
      DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), X2(1), Y
     12(1), Z2(1)
      EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON
     12), (T2Z,ITAG), (X2,SI), (Y2,ALP), (Z2,BET)
      NP=N
      MP=M
      IPSYM=0
      ITI=ITX
      IF (IX.LT.0) GO TO 19
      IF (NOP.EQ.0) RETURN
      IPSYM=1
      IF (IZ.EQ.0) GO TO 6
C
C     REFLECT ALONG Z AXIS
C
      IPSYM=2
      IF (N.LT.N2) GO TO 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) GO TO 1
      WRITE(3,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) GO TO 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) GO TO 4
      WRITE(3,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
6     IF (IY.EQ.0) GO TO 12
C
C     REFLECT ALONG Y AXIS
C
      IF (N.LT.N2) GO TO 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) GO TO 7
      WRITE(3,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) GO TO 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) GO TO 10
      WRITE(3,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
12    IF (IX.EQ.0) GO TO 18
C
C     REFLECT ALONG X AXIS
C
      IF (N.LT.N2) GO TO 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) GO TO 13
      WRITE(3,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) GO TO 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) GO TO 16
      WRITE(3,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
18    RETURN
C
C     REPRODUCE STRUCTURE WITH ROTATION TO FORM CYLINDRICAL STRUCTURE
C
19    FNOP=NOP
      IPSYM=-1
      SAM=6.283185308D+0/FNOP
      CS=COS(SAM)
      SS=SIN(SAM)
      IF (N.LT.N2) GO TO 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) GO TO 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)
23    RETURN
C
24    FORMAT (29H GEOMETRY DATA ERROR--SEGMENT,I5,26H LIES IN PLANE OF S
     1YMMETRY)
25    FORMAT (27H GEOMETRY DATA ERROR--PATCH,I4,26H LIES IN PLANE OF SYM
     1METRY)
      END
      SUBROUTINE ROM2 (A,B,SUM,DMIN)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
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
      COMPLEX*16 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
     1), 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.) GO TO 1
      WRITE(3,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) GO TO 4
      DZ=ZE-Z
      IF (DZ.LE.EP) GO TO 17
4     DZOT=DZ*.5
      CALL SFLDS (Z+DZOT,G3)
      CALL SFLDS (Z+DZ,G5)
5     TMAG1=0.
      TMAG2=0.
C
C     EVALUATE 3 POINT ROMBERG RESULT AND TEST CONVERGENCE.
C
      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) GO TO 6
      TR=DREAL(T01(I))
      TI=DIMAG(T01(I))
      TMAG1=TMAG1+TR*TR+TI*TI
      TR=DREAL(T10(I))
      TI=DIMAG(T10(I))
      TMAG2=TMAG2+TR*TR+TI*TI
6     CONTINUE
      TMAG1=SQRT(TMAG1)
      TMAG2=SQRT(TMAG2)
      CALL TEST(TMAG1,TMAG2,TR,0.D0,0.D0,TI,DMIN)
      IF(TR.GT.RX)GO TO 8
      DO 7 I=1,N
7     SUM(I)=SUM(I)+T10(I)
      NT=NT+2
      GO TO 12
8     CALL SFLDS (Z+DZ*.25,G2)
      CALL SFLDS (Z+DZ*.75,G4)
      TMAG1=0.
      TMAG2=0.
C
C     EVALUATE 5 POINT ROMBERG RESULT AND TEST CONVERGENCE.
C
      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) GO TO 9
      TR=DREAL(T11)
      TI=DIMAG(T11)
      TMAG1=TMAG1+TR*TR+TI*TI
      TR=DREAL(T20(I))
      TI=DIMAG(T20(I))
      TMAG2=TMAG2+TR*TR+TI*TI
9     CONTINUE
      TMAG1=SQRT(TMAG1)
      TMAG2=SQRT(TMAG2)
      CALL TEST(TMAG1,TMAG2,TR,0.D0,0.D0,TI,DMIN)
      IF(TR.GT.RX)GO TO 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) GO TO 17
      DO 13 I=1,N
13    G1(I)=G5(I)
      IF (NT.LT.NTS.OR.NS.LE.NX) GO TO 3
      NS=NS/2
      NT=1
      GO TO 3
14    NT=0
      IF (NS.LT.NM) GO TO 15
      WRITE(3,19)  Z
      GO TO 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)
      GO TO 5
17    CONTINUE
      RETURN
C
18    FORMAT (30H ERROR - B LESS THAN A IN ROM2)
19    FORMAT (33H ROM2 -- STEP SIZE LIMITED AT Z =,1P,E12.5)
      END
      SUBROUTINE SBF (I,IS,AA,BB,CC)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C     COMPUTE COMPONENT OF BASIS FUNCTION I ON SEGMENT IS.
      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,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
      GO TO 3
2     SIG=-SIG
      JEND=-JEND
3     JSNO=JSNO+1
      IF (JSNO.GE.JMAX) GO TO 24
      D=PI*SI(JCOX)
      SDH=SIN(D)
      CDH=COS(D)
      SD=2.*SDH*CDH
      IF (D.GT.0.015) GO TO 4
      OMC=4.*D*D
      OMC=((1.3888889D-3*OMC-4.1666666667D-2)*OMC+.5)*OMC
      GO TO 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) GO TO 6
      AA=AJ/SD*SIG
      BB=AJ/(2.*CDH)
      CC=-AJ/(2.*SDH)*SIG
      JUNE=IEND
6     IF (JCOX.EQ.I) GO TO 9
      IF (JEND.EQ.1) GO TO 7
      JCOX=ICON1(JCOX)
      GO TO 8
7     JCOX=ICON2(JCOX)
8     IF (IABS(JCOX).EQ.I) GO TO 10
      IF (JCOX) 1,24,2
9     IF (JCOX.EQ.IS) BB=-BB
10    IF (IEND.EQ.1) GO TO 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) GO TO 13
      OMC=4.*D*D
      OMC=((1.3888889D-3*OMC-4.1666666667D-2)*OMC+.5)*OMC
      GO TO 14
13    OMC=1.-CD
14    AP=1./(LOG(1./(PI*BI(I)))-.577215664D+0)
      AJ=AP
      IF (NJUN1.EQ.0) GO TO 19
      IF (NJUN2.EQ.0) GO TO 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
      GO TO 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) GO TO 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) GO TO 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) GO TO 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(3,25)  I
      STOP
C
25    FORMAT (43H SBF - SEGMENT CONNECTION ERROR FOR SEGMENT,I5)
      END
C      SUBROUTINE SECOND (CPUSECD)
C
C     Purpose:
C     SECOND returns cpu time in seconds.  Must be customized!!!
C
C     VAX or other (modify subroutine stopwtch):
C
C      REAL*8 CPUSECD
C      CALL STOPWTCH(CPUSECS,WALLTOT,CPUSPLT,WALLSPLT)
C      CPUSECD=60.*CPUSECS
C     MACINTOSH:
C      CPUSECD= LONG(362)/60.0
C      RETURN
C      END
c **********************************************************************
      SUBROUTINE SFLDS (T,E)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
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
      COMPLEX*16 E,ERV,EZV,ERH,EZH,EPH,T1,EXK,EYK,EZK,EXS,EYS,EZS,EXC
     1,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,IND1,INDD1,IND2,INDD2,IEXK,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,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,
     &KSYMP,IFAR,IPERF
      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.) GO TO 1
      RHX=1.
      RHY=0.
      PHX=0.
      PHY=1.
      GO TO 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=DCMPLX(COS(RK),-SIN(RK))
      IF (ISNOR.EQ.1) GO TO 3
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
      ZMH=1.
      R1=1.
      XX1=0.
      CALL GWAVE (ERV,EZV,ERH,EZH,EPH)
      ET=-(0.,4.77134)*FRATI*XX2/(R2S*R2)
      ER=2.*ET*DCMPLX(1.D+0,RK)
      ET=ET*DCMPLX(1.D+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
      RETURN
C
C     INTERPOLATE IN SOMMERFELD FIELD TABLES
C
3     IF (RHO.LT.1.D-12) GO TO 4
      THET=ATAN(ZPH/RHO)
      GO TO 5
4     THET=POT
5     CALL INTRP (R2,THET,ERV,EZV,ERH,EPH)
C     COMBINE VERTICAL AND HORIZONTAL COMPONENTS AND CONVERT TO X,Y,Z
C     COMPONENTS.  MULTIPLY BY EXP(-JKR)/R.
      XX2=XX2/R2
      SFAC=SN*CPH
      ERH=XX2*(SALPJ*ERV+SFAC*ERH)
      EZH=XX2*(SALPJ*EZV-SFAC*ERV)
      EPH=SN*SPH*XX2*EPH
C     X,Y,Z FIELDS FOR CONSTANT CURRENT
      E(1)=ERH*RHX+EPH*PHX
      E(2)=ERH*RHY+EPH*PHY
      E(3)=EZH
      RK=TP*T
C     X,Y,Z FIELDS FOR SINE CURRENT
      SFAC=SIN(RK)
      E(4)=E(1)*SFAC
      E(5)=E(2)*SFAC
      E(6)=E(3)*SFAC
C     X,Y,Z FIELDS FOR COSINE CURRENT
      SFAC=COS(RK)
      E(7)=E(1)*SFAC
      E(8)=E(2)*SFAC
      E(9)=E(3)*SFAC
      RETURN
      END
      SUBROUTINE SOLGF (A,B,C,D,XY,IP,NP,N1,N,MP,M1,M,N1C,N2C,N2CZ)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C     SOLVE FOR CURRENT IN N.G.F. PROCEDURE
      COMPLEX*16 A,B,C,D,SUM,XY,Y
      COMMON /SCRATM/ Y(2*MAXSEG)
      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
     1CON(10),NPCON
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
     1CASX,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
      IF (N2C.GT.0) GO TO 1
C     NORMAL SOLUTION.  NOT N.G.F.
      CALL SOLVES (A,IP,XY,N1C,1,NP,N,MP,M,13,IFL)
      GO TO 22
1     IF (N1.EQ.N.OR.M1.EQ.0) GO TO 5
C     REORDER EXCITATION ARRAY
      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) GO TO 7
      NEQ=N1C+N2C
      NEQS=NEQ-NEQS+1
C     COMPUTE INV(A)E1
      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
      NPB=NPBL
C     COMPUTE E2-C(INV(A)E1)
      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
      IF (ICASX.GT.1) REWIND 15
      JJ=N1C+1
C     COMPUTE INV(D)(E2-C(INV(A)E1)) = I2
      IF (ICASX.GT.1) GO TO 11
      CALL SOLVE (N2C,D,IP(JJ),XY(JJ),N2C)
      GO TO 13
11    IF (ICASX.EQ.4) GO TO 12
      NI=N2C*N2C
      READ (11) (B(J,1),J=1,NI)
      REWIND 11
      CALL SOLVE (N2C,B,IP(JJ),XY(JJ),N2C)
      GO TO 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
      NPB=NPBL
C     COMPUTE INV(A)E1-(INV(A)B)I2 = I1
      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
      IF (ICASX.GT.1) REWIND 14
      IF (N1.EQ.N.OR.M1.EQ.0) GO TO 20
C     REORDER CURRENT ARRAY
      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) GO TO 22
      J=NEQS-1
      DO 21 I=1,NSCON
      J=J+1
      JJ=ISCON(I)
21    XY(JJ)=XY(J)
22    RETURN
      END
      SUBROUTINE SOLVE (N,A,IP,B,NDIM)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
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.
C
      COMPLEX*16 A,B,Y,SUM
      INTEGER PI
      COMMON /SCRATM/ Y(2*MAXSEG)
      DIMENSION A(NDIM,NDIM), IP(NDIM), B(NDIM)
C
C     FORWARD SUBSTITUTION
C
      DO 3 I=1,N
      PI=IP(I)
      Y(I)=B(PI)
      B(PI)=B(I)
      IP1=I+1
      IF (IP1.GT.N) GO TO 2
      DO 1 J=IP1,N
      B(J)=B(J)-A(J,I)*Y(I)
1     CONTINUE
2     CONTINUE
3     CONTINUE
C
C     BACKWARD SUBSTITUTION
C
      DO 6 K=1,N
      I=N-K+1
      SUM=(0.,0.)
      IP1=I+1
      IF (IP1.GT.N) GO TO 5
      DO 4 J=IP1,N
      SUM=SUM+A(I,J)*B(J)
4     CONTINUE
5     CONTINUE
      B(I)=(Y(I)-SUM)/A(I,I)
6     CONTINUE
      RETURN
      END
      SUBROUTINE SOLVES (A,IP,B,NEQ,NRH,NP,N,MP,M,IFL1,IFL2)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
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
      COMPLEX*16 A,B,Y,SUM,SSX
      COMMON /SMAT/ SSX(16,16)
      COMMON /SCRATM/ Y(2*MAXSEG)
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
     1CASX,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) GO TO 11
      DO 10 IC=1,NRH
      IF (N.EQ.0.OR.M.EQ.0) GO TO 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) GO TO 3
      DO 2 I=1,NP
      IA=IA+1
      J=J+1
2     B(J,IC)=Y(IA)
      IF (K.EQ.NOP) GO TO 5
3     DO 4 I=1,KK
      IB=IB+1
      J=J+1
4     B(J,IC)=Y(IB)
5     CONTINUE
C
C     TRANSFORM MATRIX EQ. RHS VECTOR ACCORDING TO SYMMETRY MODES
C
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)*DCONJG(SSX(K,J))
10    B(IA,IC)=SUM*FNORM
11    IF (ICASE.LT.3) GO TO 12
      REWIND IFL1
      REWIND IFL2
C
C     SOLVE EACH MODE EQUATION
C
12    DO 16 KK=1,NOP
      IA=(KK-1)*NPEQ+1
      IB=IA
      IF (ICASE.NE.4) GO TO 13
      I=NPEQ*NPEQ
      READ (IFL1) (A(J),J=1,I)
      IB=1
13    IF (ICASE.EQ.3.OR.ICASE.EQ.5) GO TO 15
      DO 14 IC=1,NRH
14    CALL SOLVE (NPEQ,A(IB),IP(IA),B(IA,IC),NROW)
      GO TO 16
15    CALL LTSOLV (A,NPEQ,IP(IA),B(IA,1),NEQ,NRH,IFL1,IFL2)
16    CONTINUE
      IF (NOP.EQ.1) RETURN
C
C     INVERSE TRANSFORM THE MODE SOLUTIONS
C
      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) GO TO 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) GO TO 23
      DO 22 I=1,NP
      IA=IA+1
      J=J+1
22    B(IA,IC)=Y(J)
      IF (K.EQ.NOP) GO TO 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
      SUBROUTINE TBF (I,ICAP)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C     COMPUTE BASIS FUNCTION I
      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM
      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
     1CON(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
      GO TO 3
2     SIG=-SIG
      JEND=-JEND
3     JSNO=JSNO+1
      IF (JSNO.GE.JMAX) GO TO 28
      JCO(JSNO)=JCOX
      D=PI*SI(JCOX)
      SDH=SIN(D)
      CDH=COS(D)
      SD=2.*SDH*CDH
      IF (D.GT.0.015) GO TO 4
      OMC=4.*D*D
      OMC=((1.3888889D-3*OMC-4.1666666667D-2)*OMC+.5)*OMC
      GO TO 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) GO TO 8
      IF (JEND.EQ.1) GO TO 6
      JCOX=ICON1(JCOX)
      GO TO 7
6     JCOX=ICON2(JCOX)
7     IF (IABS(JCOX).EQ.I) GO TO 9
      IF (JCOX) 1,28,2
8     BX(JSNO)=-BX(JSNO)
9     IF (IEND.EQ.1) GO TO 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) GO TO 12
      OMC=4.*D*D
      OMC=((1.3888889D-3*OMC-4.1666666667D-2)*OMC+.5)*OMC
      GO TO 13
12    OMC=1.-CD
13    AP=1./(LOG(1./(PI*BI(I)))-.577215664D+0)
      AJ=AP
      IF (NJUN1.EQ.0) GO TO 16
      IF (NJUN2.EQ.0) GO TO 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
      GO TO 27
16    IF (NJUN2.EQ.0) GO TO 24
      IF (ICAP.NE.0) GO TO 17
      XXI=0.
      GO TO 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
      GO TO 27
20    IF (ICAP.NE.0) GO TO 21
      XXI=0.
      GO TO 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
      GO TO 27
24    BX(JSNOP)=0.
      IF (ICAP.NE.0) GO TO 25
      XXI=0.
      GO TO 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(3,29)  I
      STOP
C
29    FORMAT (43H TBF - SEGMENT CONNECTION ERROR FOR SEGMENT,I5)
      END
      SUBROUTINE TEST (F1R,F2R,TR,F1I,F2I,TI,DMIN)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     TEST FOR CONVERGENCE IN NUMERICAL INTEGRATION
C
      DEN=ABS(F2R)
      TR=ABS(F2I)
      IF (DEN.LT.TR) DEN=TR
      IF (DEN.LT.DMIN) DEN=DMIN
      IF (DEN.LT.1.D-37) GO TO 1
      TR=ABS((F1R-F2R)/DEN)
      TI=ABS((F1I-F2I)/DEN)
      RETURN
1     TR=0.
      TI=0.
      RETURN
      END
      SUBROUTINE TRIO (J)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C     COMPUTE THE COMPONENTS OF ALL BASIS FUNCTIONS ON SEGMENT J
      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM
      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP
     1CON(10),NPCON
      DATA JMAX/30/
      JSNO=0
      JCOX=ICON1(J)
      IF (JCOX.GT.10000) GO TO 7
      JEND=-1
      IEND=-1
      IF (JCOX) 1,7,2
1     JCOX=-JCOX
      GO TO 3
2     JEND=-JEND
3     IF (JCOX.EQ.J) GO TO 6
      JSNO=JSNO+1
      IF (JSNO.GE.JMAX) GO TO 9
      CALL SBF (JCOX,J,AX(JSNO),BX(JSNO),CX(JSNO))
      JCO(JSNO)=JCOX
      IF (JEND.EQ.1) GO TO 4
      JCOX=ICON1(JCOX)
      GO TO 5
4     JCOX=ICON2(JCOX)
5     IF (JCOX) 1,9,2
6     IF (IEND.EQ.1) GO TO 8
7     JCOX=ICON2(J)
      IF (JCOX.GT.10000) GO TO 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(3,10)  J
      STOP
C
10    FORMAT (44H TRIO - SEGMENT CONNENTION ERROR FOR SEGMENT,I5)
      END
      SUBROUTINE UNERE (XOB,YOB,ZOB)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C     CALCULATES THE ELECTRIC FIELD DUE TO UNIT CURRENT IN THE T1 AND T2
C     DIRECTIONS ON A PATCH
      COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,ZRATI,ZRATI2,T1
     1,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,IND1,INDD1,IND2,INDD2,IEXK,IPGND
      COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,
     &KSYMP,IFAR,IPERF
      EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y
     1J,IND1), (T2ZJ,IND2)
      DATA TPI,CONST/6.283185308D+0,4.771341188D+0/
C     CONST=ETA/(8.*PI**2)
      ZR=ZJ
      T1ZR=T1ZJ
      T2ZR=T2ZJ
      IF (IPGND.NE.2) GO TO 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) GO TO 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=DCMPLX(SIN(TT1),-COS(TT1))*(CONST*S)
      Q1=DCMPLX(TT2-1.,TT1)*ER/RT
      Q2=DCMPLX(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) GO TO 6
      IF (IPERF.NE.1) GO TO 3
      EXK=-EXK
      EYK=-EYK
      EZK=-EZK
      EXS=-EXS
      EYS=-EYS
      EZS=-EZS
      GO TO 6
3     XYMAG=SQRT(RX*RX+RY*RY)
      IF (XYMAG.GT.1.D-6) GO TO 4
      PX=0.
      PY=0.
      CTH=1.
      RRV=(1.,0.)
      GO TO 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
      SUBROUTINE WIRE (XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,RDEL,RRAD,NS,ITG)
C ***
C     DOUBLE PRECISION 6/4/85
C
      INCLUDE 'NEC2DPAR.INC'
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     SUBROUTINE WIRE GENERATES SEGMENT GEOMETRY DATA FOR A STRAIGHT
C     WIRE OF NS SEGMENTS.
C
      COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
     &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
     &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,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) GO TO 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
      GO TO 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
      COMPLEX*16 FUNCTION ZINT(SIGL,ROLAM)
C ***
C     DOUBLE PRECISION 6/4/85
C
      IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C     ZINT COMPUTES THE INTERNAL IMPEDANCE OF A CIRCULAR WIRE
C
C
      COMPLEX*16 TH,PH,F,G,FJ,CN,BR1,BR2
      COMPLEX*16 CC1,CC2,CC3,CC4,CC5,CC6,CC7,CC8,CC9,CC10,CC11,CC12
     1,CC13,CC14
      DIMENSION FJX(2), CNX(2), CCN(28)
      EQUIVALENCE (FJ,FJX), (CN,CNX), (CC1,CCN(1)), (CC2,CCN(3)), (CC3,C
     1CN(5)), (CC4,CCN(7)), (CC5,CCN(9)), (CC6,CCN(11)), (CC7,CCN(13)),
     2(CC8,CCN(15)), (CC9,CCN(17)), (CC10,CCN(19)), (CC11,CCN(21)), (CC1
     32,CCN(23)), (CC13,CCN(25)), (CC14,CCN(27))
      DATA PI,POT,TP,TPCMU/3.1415926D+0,1.5707963D+0,6.2831853D+0,
     12.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
     1,0.,-9.765D-4,.0110486D+0,-.0110485D+0,0.,-.3926991D+0,1.6D-6,
     2-3.2D-6,1.17D-5,-2.4D-6,3.46D-5,3.38D-5,5.D-7,2.452D-4,-1.3813D-3
     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.) GO TO 2
      IF (X.GT.8.) GO TO 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)
     1*S-32.363456D+0)*S+113.77778D+0)*S-64.)*S+1.
      BEI=((((((1.1346D-4*S-.01103667D+0)*S+.52185615D+0)*S-
     110.567658D+0)*S+72.817777D+0)*S-113.77778D+0)*S+16.)*Y
      BR1=DCMPLX(BER,BEI)
      BER=(((((((-3.94D-6*S+4.5957D-4)*S-.02609253D+0)*S+.66047849D+0)
     1*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)
     1*S+11.377778D+0)*S-10.666667D+0)*S+.5)*X
      BR2=DCMPLX(BER,BEI)
      BR1=BR1/BR2
      GO TO 3
1     BR2=FJ*F(X)/PI
      BR1=G(X)+BR2
      BR2=G(X)*PH(8./X)-BR2*PH(-8./X)
      BR1=BR1/BR2
      GO TO 3
2     BR1=DCMPLX(.70710678D+0,-.70710678D+0)
3     ZINT=FJ*SQRT(CMOTP/SIGL)*BR1/ROLAM
      RETURN
      END
      logical*4 function GetPut(what,where,message,file,volume,nt,types)
C
C      implicit none
C
C      integer NEWHANDLE
C      parameter (NEWHANDLE = Z'122000A8')
C      integer HLOCK
C      parameter (HLOCK = Z'02980008')
C      integer HUNLOCK
C      parameter (HUNLOCK = Z'02A80008')
C      integer NEWDIALOG
C      parameter (NEWDIALOG = Z'97D20002')
C      integer DISPOSHANDLE
C      parameter (DISPOSHANDLE = Z'02380008')
C      integer SFPUTFILE
C      parameter (SFPUTFILE = Z'9EA16CB1')
C      integer SFGETFILE
C      parameter (SFGETFILE = Z'9EA20003')
C      integer PTR
C      parameter (PTR = Z'C0000000')
C      integer DISPOSEDIALOG
C      parameter (DISPOSEDIALOG = Z'98310000')
C      integer PBSETVOL
C      parameter (PBSETVOL = Z'01580010')
C
C      integer*4 what                ! 0 SFPUTFILE; 1 SFGETFILE
C      integer*2 where(2)            ! location of box upper-left corner (y,x)
C      character*(*) message         ! string to go over dialog box
C      character*(*) file            ! file name
C      integer*4 volume              ! volume number
C      integer*4 nt                  ! number of filter types
C      character*(*) types           ! filter types
C
C      integer*4 toolbx              ! toolbx interface
C
C      integer*4 dptr                ! dialog pointer
C      character*64 fname
C      logical*1 good                ! result flag
C      integer*4 i
C      integer*2 iovrefnum
C      integer*4 lhdl                      ! handle of item list
C      integer*4 lptr                      ! pointer to item list
C      integer*4 nc                        ! number of characters in file name
C      integer*2 posd(2)                   ! location of standard dialog
C      integer*2 rect(4)                   ! rectangle
C      integer*2 vrefnum
C      integer*1 params(108)                ! partial PBGETVOL parameter block
C      equivalence (params(23),iovrefnum)
C      integer*1 reply(76)                 ! reply record
C      equivalence (reply(1),good)
C      equivalence (reply(7),vrefnum)
C      equivalence (reply(11),fname)
C
      GetPut = .false.
C      volume = 0
C      good = .true.
C      if (what .eq. 0) then
C        lhdl = 0
C        lhdl = toolbx(NEWHANDLE,72)
C        if (lhdl .eq. 0) return
C        call toolbx(HLOCK,lhdl)
C        lptr = LONG(lhdl)
C        WORD(lptr) = 1
C        LONG(lptr + 2) = 0
C        WORD(lptr + 6) = 0
C        WORD(lptr + 8) = 0
C        WORD(lptr + 10) = 32
C        WORD(lptr + 12) = 32
C        BYTE(lptr + 14) = 160
C        BYTE(lptr + 15) = 2
C        WORD(lptr + 16) = 1
C        LONG(lptr + 18) = 0
C        WORD(lptr + 22) = 8
C        WORD(lptr + 24) = 40
C        WORD(lptr + 26) = 24
C        WORD(lptr + 28) = 304
C        BYTE(lptr + 30) = 136
C        BYTE(lptr + 31) = 40
C        do (i = 1, 40)
C          BYTE(lptr + 31 + i) = ICHAR(message(i:i))
C        enddo
C        call toolbx(HUNLOCK,lhdl)
C        rect(1) = where(1)
C        rect(2) = where(2)
C        rect(3) = rect(1) + 32
C        rect(4) = rect(2) + 304
C      elseif (what .eq. 1) then
C        lhdl = 0
C        lhdl = toolbx(NEWHANDLE,80)
C        if (lhdl .eq. 0) return
C        call toolbx(HLOCK,lhdl)
C        lptr = LONG(lhdl)
C        WORD(lptr) = 1
C        LONG(lptr + 2) = 0
C        WORD(lptr + 6) = 0
C        WORD(lptr + 8) = 0
C        WORD(lptr + 10) = 32
C        WORD(lptr + 12) = 32
C        BYTE(lptr + 14) = 160
C        BYTE(lptr + 15) = 2
C        WORD(lptr + 16) = 1
C        LONG(lptr + 18) = 0
C        WORD(lptr + 22) = 8
C        WORD(lptr + 24) = 40
C        WORD(lptr + 26) = 24
C        WORD(lptr + 28) = 348
C        BYTE(lptr + 30) = 136
C        BYTE(lptr + 31) = 48
C        do (i = 1, 48)
C          BYTE(lptr + 31 + i) = ICHAR(message(i:i))
C        enddo
C        call toolbx(HUNLOCK,lhdl)
C        rect(1) = where(1)
C        rect(2) = where(2)
C        rect(3) = rect(1) + 32
C        rect(4) = rect(2) + 348
C      else
C        return
C      endif
C      dptr = 0
C      dptr = toolbx(NEWDIALOG,0,rect,0,.true.,1,-1,.false.,0,lhdl)
C      if (dptr .eq. 0) then
C        call toolbx(DISPOSHANDLE,lhdl)
C        return
C      endif
C      posd(1) = where(1) + 50
C      posd(2) = where(2)
C      if (what .eq. 0) then
C        call toolbx(SFPUTFILE,posd,0,0,0,reply,1)
C      else
C        call toolbx(SFGETFILE,posd,0,0,nt,toolbx(PTR,types),0,reply,2)
C      endif
C      call toolbx(DISPOSEDIALOG,dptr)                 ! Dispose of Header dialog
C      if (good .eq. .false.) return
C      nc = ICHAR(fname(1:1))
C      file = fname(2:nc + 1)
C      do (i = 1, 108)
C        params(i) = 0
C      enddo
C      iovrefnum = vrefnum
C      if (toolbx(PBSETVOL,toolbx(PTR,params)) .eq. 0) then
C        GetPut = .true.
C        volume = vrefnum
C      endif
C
      return
      end

Generated by  Doxygen 1.6.0   Back to index