home *** CD-ROM | disk | FTP | other *** search
/ Antennas / Antennas_CD-ROM_Walnut_Creek_September_1996.iso / nec / c / nec2.f < prev    next >
Encoding:
Text File  |  1996-06-30  |  288.2 KB  |  9,077 lines
  1. C     PROGRAM NEC(INPUT,TAPE5=INPUT,OUTPUT,TAPE11,TAPE12,TAPE13,TAPE14, 
  2. C    1TAPE15,TAPE16,TAPE20,TAPE21)                                      
  3. C                                                                       
  4. C     NUMERICAL ELECTROMAGNETICS CODE (NEC2)  DEVELOPED AT LAWRENCE     
  5. C     LIVERMORE LAB., LIVERMORE, CA.  (CONTACT G. BURKE AT 415-422-8414 
  6. C     FOR PROBLEMS WITH THE NEC CODE.  FOR PROBLEMS WITH THE VAX IMPLEM-
  7. C     ENTATION, CONTACT J. BREAKALL AT 415-422-8196 OR E. DOMNING AT 415
  8. C     422-5936)
  9. C     FILE CREATED 4/11/80.                                             
  10. C                                                                       
  11. C                ***********NOTICE**********                            
  12. C     THIS COMPUTER CODE MATERIAL WAS PREPARED AS AN ACCOUNT OF WORK    
  13. C     SPONSORED BY THE UNITED STATES GOVERNMENT.  NEITHER THE UNITED    
  14. C     STATES NOR THE UNITED STATES DEPARTMENT OF ENERGY, NOR ANY OF     
  15. C     THEIR EMPLOYEES, NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR 
  16. C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR       
  17. C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY,   
  18. C     COMPLETENESS OR USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT 
  19. C     OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT        
  20. C     INFRINGE PRIVATELY-OWNED RIGHTS.                                  
  21. C                                                                       
  22. C***
  23. C ***
  24. C     DOUBLE PRECISION 6/4/85
  25. C
  26. C ***
  27.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  28.       CHARACTER   AIN*2, ATST*2, INFILE*80, OTFILE*80
  29. C***
  30.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  31. C     INTEGER  AIN,ATST,PNET,HPOL                                       
  32. C     REAL RHPOL,PNET 
  33.       COMPLEX  CM, FJ, VSANT, ETH, EPH, ZRATI, CUR, CURI, ZARRAY, 
  34.      &ZRATI2
  35.       COMPLEX  EX, EY, EZ, ZPED, VQD, VQDS, T1, Y11A, Y12A, EPSC, U,
  36.      & U2, XX1, XX2
  37.       COMPLEX  AR1, AR2, AR3, EPSCF, FRATI
  38.       COMMON  /CMB/ CM(90000)
  39.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  40.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  41.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  42.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  43.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  44.       COMMON  /SAVE/COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(N2M),KCOM
  45.       COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM), 
  46.      &CII( NM), CUR( N3M)
  47.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  48.      &KSYMP, IFAR, IPERF, T1, T2
  49.       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
  50.       COMMON  /YPARM/ NCOUP, ICOUP, NCTAG(5), NCSEG(5), Y11A(5), Y12A(
  51.      &20)
  52.       COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50), 
  53.      &NSCON, IPCON(10), NPCON
  54.       COMMON  /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
  55.      &, IQDS(30), NVQD, NSANT, NQDS
  56.       COMMON/NETCX/ZPED,PIN,PNLS,X11R(150),X11I(150),X12R(150),
  57.      &X12I(150),X22R(150),X22I(150),NTYP(150),NEQ,NPEQ,NEQ2,NONET,NTSOL
  58.      &,NPRINT,MASYM,ISEG1(150),ISEG2(150)
  59.       COMMON  /FPAT/ THETS, PHIS, DTH, DPH, RFLD, GNOR, CLT, CHT, EPSR2,
  60.      & SIG2, XPR6, PINR, PNLR, PLOSS, XNR, YNR, ZNR, DXNR, DYNR, DZNR,
  61.      &NTH, NPH, IPD, IAVP, INOR, IAX, IXTYP, NEAR, NFEH, NRX, NRY, NRZ 
  62.       COMMON  /GGRID/ AR1(11,10,4), AR2(17,5,4), AR3(9,8,4), EPSCF, DXA
  63.      &(3), DYA(3), XSA(3), YSA(3), NXA(3), NYA(3)
  64. C***
  65.       COMMON  /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
  66. C***
  67.       COMMON  /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
  68.       DIMENSION  CAB(1), SAB(1), X2(1), Y2(1), Z2(1)
  69.       DIMENSION  LDTYP(200), LDTAG(200), LDTAGF(200), LDTAGT(200), 
  70.      & ZLR(200), ZLI(200), ZLC(200)
  71.       DIMENSION   IX( N2M)
  72.       DIMENSION  FNORM(200)
  73. C***
  74.       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  75.       DIMENSION  XTEMP( NM), YTEMP( NM), ZTEMP( NM), SITEMP( NM), 
  76.      &BITEMP( NM)
  77.       EQUIVALENCE(CAB,ALP),(SAB,BET),(X2,SI),(Y2,ALP),(Z2,BET)
  78.       EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
  79.      &T2Z,ITAG)
  80.       CHARACTER*2 ATST(22)
  81.       CHARACTER*6 HPOL(3)
  82.       CHARACTER*6 PNET(6)
  83.       DATA   ATST/'CE','FR','LD','GN','EX','NT','XQ','NE','GD','RP',
  84.      &'CM','NX','EN','TL','PT','KH','NH','PQ','EK','WG','CP','PL'/
  85. C
  86. C
  87. C
  88.       DATA   HPOL/6HLINEAR,5HRIGHT,4HLEFT/
  89. C
  90. C
  91.       DATA   PNET/6H      ,2H  ,6HSTRAIG,2HHT,6HCROSSE,1HD/
  92.       DATA   TA/1.745329252D-02/, CVEL/299.8/
  93. C***
  94.       DATA   LOADMX, NSMAX, NETMX/200,150,150/, NORMF/200/
  95.   706 CONTINUE
  96.       PRINT700 
  97.   700 FORMAT('$ENTER DATA INPUT FILENAME [HIT RETURN FOR TERMINAL',
  98.      &' INPUT] : ',/,'$     >')
  99.   701 FORMAT(A)
  100.       READ( *,701,ERR=702)  INFILE
  101.       CALL STR0PC( INFILE, INFILE)
  102. CJCB   OPEN (UNIT=5,FILE=INFILE,STATUS='OLD',READONLY,ERR=702)
  103.       IF( INFILE.NE.' ') THEN
  104.       OPEN ( UNIT=5,FILE=INFILE,STATUS='OLD',ERR=702,BLANK='NULL')
  105.       ENDIF
  106.   707 CONTINUE
  107.       PRINT703 
  108.   703 FORMAT('$ENTER DATA OUTPUT FILENAME [HIT RETURN FOR TERMINAL',
  109.      &' OUTPUT] : ',/,'$     >')
  110.       READ( *,701,ERR=704)  OTFILE
  111.       CALL STR0PC( OTFILE, OTFILE)
  112.       IF( OTFILE.NE.' ') THEN
  113.       OPEN ( UNIT=6,FILE=OTFILE,STATUS='NEW',ERR=704)
  114.       ENDIF
  115.       GOTO 705
  116.   702 CALL ERROR
  117.       GOTO 706
  118.   704 CALL ERROR
  119.       GOTO 707
  120. C***
  121.   705 CONTINUE
  122.       CALL SECNDS(EXTIM)
  123.       FJ=(0.,1.)
  124.       LD=600
  125.       NXA(1)=0
  126.       IRESRV=90000
  127. C***
  128.     1 KCOM=0
  129.       IFRTMW=0
  130. C***
  131.       IFRTMP=0
  132.     2 KCOM= KCOM+1
  133.       IF( KCOM.GT.5) KCOM=5
  134. C***
  135.       READ( 5,125)  AIN,( COM( I, KCOM), I=1,19)
  136. C***
  137.       CALL STR0PC( AIN, AIN)
  138.       IF( KCOM.GT.1) GOTO 3
  139.       WRITE( 6,126) 
  140.       WRITE( 6,127) 
  141.       WRITE( 6,128) 
  142.     3 WRITE( 6,129) ( COM( I, KCOM), I=1,19)
  143.       IF( AIN.EQ. ATST(11)) GOTO 2
  144.       IF( AIN.EQ. ATST(1)) GOTO 4
  145.       WRITE( 6,130) 
  146.       STOP
  147.     4 CONTINUE
  148.       DO 5  I=1, LD
  149.     5 ZARRAY( I)=(0.,0.)
  150.       MPCNT=0
  151. C                                                                       
  152. C     SET UP GEOMETRY DATA IN SUBROUTINE DATAGN                         
  153. C                                                                       
  154.       IMAT=0
  155.       CALL DATAGN
  156.       IFLOW=1
  157. C                                                                       
  158. C     CORE ALLOCATION FOR ARRAYS B, C, AND D FOR N.G.F. SOLUTION        
  159. C                                                                       
  160.       IF( IMAT.EQ.0) GOTO 326
  161.       NEQ= N1+2* M1
  162.       NEQ2= N- N1+2*( M- M1)+ NSCON+2* NPCON
  163.       CALL FBNGF( NEQ, NEQ2, IRESRV, IB11, IC11, ID11, IX11)
  164.       GOTO 6
  165.   326 NEQ= N+2* M
  166.       NEQ2=0
  167.       IB11=1
  168.       IC11=1
  169.       ID11=1
  170.       IX11=1
  171.       ICASX=0
  172.     6 NPEQ= NP+2* MP
  173. C                                                                       
  174. C     DEFAULT VALUES FOR INPUT PARAMETERS AND FLAGS                     
  175. C                                                                       
  176. C***
  177.       WRITE( 6,135) 
  178.       IPLP1=0
  179.       IPLP2=0
  180.       IPLP3=0
  181. C***
  182.       IPLP4=0
  183.       IGO=1
  184.       FMHZS= CVEL
  185.       NFRQ=1
  186.       RKH=1.
  187.       IEXK=0
  188.       IXTYP=0
  189.       NLOAD=0
  190.       NONET=0
  191.       NEAR=-1
  192.       IPTFLG=-2
  193.       IPTFLQ=-1
  194.       IFAR=-1
  195.       ZRATI=(1.,0.)
  196.       IPED=0
  197.       IRNGF=0
  198.       NCOUP=0
  199.       ICOUP=0
  200.       IF( ICASX.GT.0) GOTO 14
  201.       FMHZ= CVEL
  202.       NLODF=0
  203.       KSYMP=1
  204.       NRADL=0
  205. C                                                                       
  206. C     MAIN INPUT SECTION - STANDARD READ STATEMENT - JUMPS TO APPRO-    
  207. C     PRIATE SECTION FOR SPECIFIC PARAMETER SET UP                      
  208. C                                                                       
  209. C14    READ(5,136)AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,TMP4,TMP5, 
  210. C     1TMP6                                                             
  211. C***
  212.       IPERF=0
  213. C***
  214.    14 CALL READMN( AIN, ITMP1, ITMP2, ITMP3, ITMP4, TMP1, TMP2, TMP3, 
  215.      &TMP4, TMP5, TMP6)
  216.       MPCNT= MPCNT+1
  217.       WRITE( 6,137)  MPCNT, AIN, ITMP1, ITMP2, ITMP3, ITMP4, TMP1, TMP2
  218.      &, TMP3, TMP4, TMP5, TMP6
  219.       IF( AIN.EQ. ATST(2)) GOTO 16
  220.       IF( AIN.EQ. ATST(3)) GOTO 17
  221.       IF( AIN.EQ. ATST(4)) GOTO 21
  222.       IF( AIN.EQ. ATST(5)) GOTO 24
  223.       IF( AIN.EQ. ATST(6)) GOTO 28
  224.       IF( AIN.EQ. ATST(14)) GOTO 28
  225.       IF( AIN.EQ. ATST(15)) GOTO 31
  226.       IF( AIN.EQ. ATST(18)) GOTO 319
  227.       IF( AIN.EQ. ATST(7)) GOTO 37
  228.       IF( AIN.EQ. ATST(8)) GOTO 32
  229.       IF( AIN.EQ. ATST(17)) GOTO 208
  230.       IF( AIN.EQ. ATST(9)) GOTO 34
  231.       IF( AIN.EQ. ATST(10)) GOTO 36
  232.       IF( AIN.EQ. ATST(16)) GOTO 305
  233.       IF( AIN.EQ. ATST(19)) GOTO 320
  234.       IF( AIN.EQ. ATST(12)) GOTO 1
  235.       IF( AIN.EQ. ATST(20)) GOTO 322
  236. C***
  237.       IF( AIN.EQ. ATST(21)) GOTO 304
  238. C***
  239.       IF( AIN.EQ. ATST(22)) GOTO 330
  240.       IF( AIN.NE. ATST(13)) GOTO 15
  241.       CALL SECNDS( TMP1)
  242.       TMP1= TMP1- EXTIM
  243.       WRITE( 6,201)  TMP1
  244.       STOP
  245.    15 WRITE( 6,138) 
  246. C                                                                       
  247. C     FREQUENCY PARAMETERS                                              
  248. C                                                                       
  249.       STOP
  250.    16 IFRQ= ITMP1
  251.       IF( ICASX.EQ.0) GOTO 8
  252.       WRITE( 6,303)  AIN
  253.       STOP
  254.     8 NFRQ= ITMP2
  255.       IF( NFRQ.EQ.0) NFRQ=1
  256.       FMHZ= TMP1
  257.       DELFRQ= TMP2
  258.       IF( IPED.EQ.1) ZPNORM=0.
  259.       IGO=1
  260.       IFLOW=1
  261. C                                                                       
  262. C     MATRIX INTEGRATION LIMIT                                          
  263. C                                                                       
  264.       GOTO 14
  265.   305 RKH= TMP1
  266.       IF( IGO.GT.2) IGO=2
  267.       IFLOW=1
  268. C                                                                       
  269. C     EXTENDED THIN WIRE KERNEL OPTION                                  
  270. C                                                                       
  271.       GOTO 14
  272.   320 IEXK=1
  273.       IF( ITMP1.EQ.-1) IEXK=0
  274.       IF( IGO.GT.2) IGO=2
  275.       IFLOW=1
  276. C                                                                       
  277. C     MAXIMUM COUPLING BETWEEN ANTENNAS                                 
  278. C                                                                       
  279.       GOTO 14
  280.   304 IF( IFLOW.NE.2) NCOUP=0
  281.       ICOUP=0
  282.       IFLOW=2
  283.       IF( ITMP2.EQ.0) GOTO 14
  284.       NCOUP= NCOUP+1
  285.       IF( NCOUP.GT.5) GOTO 312
  286.       NCTAG( NCOUP)= ITMP1
  287.       NCSEG( NCOUP)= ITMP2
  288.       IF( ITMP4.EQ.0) GOTO 14
  289.       NCOUP= NCOUP+1
  290.       IF( NCOUP.GT.5) GOTO 312
  291.       NCTAG( NCOUP)= ITMP3
  292.       NCSEG( NCOUP)= ITMP4
  293.       GOTO 14
  294.   312 WRITE( 6,313) 
  295. C                                                                       
  296. C     LOADING PARAMETERS                                                
  297. C                                                                       
  298.       STOP
  299.    17 IF( IFLOW.EQ.3) GOTO 18
  300.       NLOAD=0
  301.       IFLOW=3
  302.       IF( IGO.GT.2) IGO=2
  303.       IF( ITMP1.EQ.(-1)) GOTO 14
  304.    18 NLOAD= NLOAD+1
  305.       IF( NLOAD.LE. LOADMX) GOTO 19
  306.       WRITE( 6,139) 
  307.       STOP
  308.    19 LDTYP( NLOAD)= ITMP1
  309.       LDTAG( NLOAD)= ITMP2
  310.       IF( ITMP4.EQ.0) ITMP4= ITMP3
  311.       LDTAGF( NLOAD)= ITMP3
  312.       LDTAGT( NLOAD)= ITMP4
  313.       IF( ITMP4.GE. ITMP3) GOTO 20
  314.       WRITE( 6,140)  NLOAD, ITMP3, ITMP4
  315.       STOP
  316.    20 ZLR( NLOAD)= TMP1
  317.       ZLI( NLOAD)= TMP2
  318.       ZLC( NLOAD)= TMP3
  319. C                                                                       
  320. C     GROUND PARAMETERS UNDER THE ANTENNA                               
  321. C                                                                       
  322.       GOTO 14
  323.    21 IFLOW=4
  324.       IF( ICASX.EQ.0) GOTO 10
  325.       WRITE( 6,303)  AIN
  326.       STOP
  327.    10 IF( IGO.GT.2) IGO=2
  328.       IF( ITMP1.NE.(-1)) GOTO 22
  329.       KSYMP=1
  330.       NRADL=0
  331.       IPERF=0
  332.       GOTO 14
  333.    22 IPERF= ITMP1
  334.       NRADL= ITMP2
  335.       KSYMP=2
  336.       EPSR= TMP1
  337.       SIG= TMP2
  338.       IF( NRADL.EQ.0) GOTO 23
  339.       IF( IPERF.NE.2) GOTO 314
  340.       WRITE( 6,390) 
  341.       STOP
  342.   314 SCRWLT= TMP3
  343.       SCRWRT= TMP4
  344.       GOTO 14
  345.    23 EPSR2= TMP3
  346.       SIG2= TMP4
  347.       CLT= TMP5
  348.       CHT= TMP6
  349. C                                                                       
  350. C     EXCITATION PARAMETERS                                             
  351. C                                                                       
  352.       GOTO 14
  353.    24 IF( IFLOW.EQ.5) GOTO 25
  354.       NSANT=0
  355.       NVQD=0
  356.       IPED=0
  357.       IFLOW=5
  358.       IF( IGO.GT.3) IGO=3
  359.    25 MASYM= ITMP4/10
  360.       IF( ITMP1.GT.0.AND. ITMP1.NE.5) GOTO 27
  361.       IXTYP= ITMP1
  362.       NTSOL=0
  363.       IF( IXTYP.EQ.0) GOTO 205
  364.       NVQD= NVQD+1
  365.       IF( NVQD.GT. NSMAX) GOTO 206
  366.       IVQD( NVQD)= ISEGNO( ITMP2, ITMP3)
  367.       VQD( NVQD)= CMPLX( TMP1, TMP2)
  368.       IF( ABS( VQD( NVQD)).LT.1.D-20) VQD( NVQD)=(1.,0.)
  369.       GOTO 207
  370.   205 NSANT= NSANT+1
  371.       IF( NSANT.LE. NSMAX) GOTO 26
  372.   206 WRITE( 6,141) 
  373.       STOP
  374.    26 ISANT( NSANT)= ISEGNO( ITMP2, ITMP3)
  375.       VSANT( NSANT)= CMPLX( TMP1, TMP2)
  376.       IF( ABS( VSANT( NSANT)).LT.1.D-20) VSANT( NSANT)=(1.,0.)
  377.   207 IPED= ITMP4- MASYM*10
  378.       ZPNORM= TMP3
  379.       IF( IPED.EQ.1.AND. ZPNORM.GT.0) IPED=2
  380.       GOTO 14
  381.    27 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) NTSOL=0
  382.       IXTYP= ITMP1
  383.       NTHI= ITMP2
  384.       NPHI= ITMP3
  385.       XPR1= TMP1
  386.       XPR2= TMP2
  387.       XPR3= TMP3
  388.       XPR4= TMP4
  389.       XPR5= TMP5
  390.       XPR6= TMP6
  391.       NSANT=0
  392.       NVQD=0
  393.       THETIS= XPR1
  394.       PHISS= XPR2
  395. C                                                                       
  396. C     NETWORK PARAMETERS                                                
  397. C                                                                       
  398.       GOTO 14
  399.    28 IF( IFLOW.EQ.6) GOTO 29
  400.       NONET=0
  401.       NTSOL=0
  402.       IFLOW=6
  403.       IF( IGO.GT.3) IGO=3
  404.       IF( ITMP2.EQ.(-1)) GOTO 14
  405.    29 NONET= NONET+1
  406.       IF( NONET.LE. NETMX) GOTO 30
  407.       WRITE( 6,142) 
  408.       STOP
  409.    30 NTYP( NONET)=2
  410.       IF( AIN.EQ. ATST(6)) NTYP( NONET)=1
  411.       ISEG1( NONET)= ISEGNO( ITMP1, ITMP2)
  412.       ISEG2( NONET)= ISEGNO( ITMP3, ITMP4)
  413.       X11R( NONET)= TMP1
  414.       X11I( NONET)= TMP2
  415.       X12R( NONET)= TMP3
  416.       X12I( NONET)= TMP4
  417.       X22R( NONET)= TMP5
  418.       X22I( NONET)= TMP6
  419.       IF( NTYP( NONET).EQ.1.OR. TMP1.GT.0.) GOTO 14
  420.       NTYP( NONET)=3
  421. C***
  422. C
  423. C     PLOT FLAGS
  424. C
  425.       X11R( NONET)=- TMP1
  426.   330 IPLP1= ITMP1
  427.       IPLP2= ITMP2
  428.       IPLP3= ITMP3
  429. C***
  430.       IPLP4= ITMP4
  431. C                                                                       
  432. C     PRINT CONTROL FOR CURRENT                                         
  433. C                                                                       
  434.       GOTO 14
  435.    31 IPTFLG= ITMP1
  436.       IPTAG= ITMP2
  437.       IPTAGF= ITMP3
  438.       IPTAGT= ITMP4
  439.       IF( ITMP3.EQ.0.AND. IPTFLG.NE.-1) IPTFLG=-2
  440.       IF( ITMP4.EQ.0) IPTAGT= IPTAGF
  441. C                                                                       
  442. C     WRITE CONTROL FOR CHARGE                                          
  443. C                                                                       
  444.       GOTO 14
  445.   319 IPTFLQ= ITMP1
  446.       IPTAQ= ITMP2
  447.       IPTAQF= ITMP3
  448.       IPTAQT= ITMP4
  449.       IF( ITMP3.EQ.0.AND. IPTFLQ.NE.-1) IPTFLQ=-2
  450.       IF( ITMP4.EQ.0) IPTAQT= IPTAQF
  451. C                                                                       
  452. C     NEAR FIELD CALCULATION PARAMETERS                                 
  453. C                                                                       
  454.       GOTO 14
  455.   208 NFEH=1
  456.       GOTO 209
  457.    32 NFEH=0
  458.   209 IF(.NOT.( IFLOW.EQ.8.AND. NFRQ.NE.1)) GOTO 33
  459.       WRITE( 6,143) 
  460.    33 NEAR= ITMP1
  461.       NRX= ITMP2
  462.       NRY= ITMP3
  463.       NRZ= ITMP4
  464.       XNR= TMP1
  465.       YNR= TMP2
  466.       ZNR= TMP3
  467.       DXNR= TMP4
  468.       DYNR= TMP5
  469.       DZNR= TMP6
  470.       IFLOW=8
  471.       IF( NFRQ.NE.1) GOTO 14
  472. C                                                                       
  473. C     GROUND REPRESENTATION                                             
  474. C                                                                       
  475.       GOTO (41,46,53,71,72), IGO
  476.    34 EPSR2= TMP1
  477.       SIG2= TMP2
  478.       CLT= TMP3
  479.       CHT= TMP4
  480.       IFLOW=9
  481. C                                                                       
  482. C     STANDARD OBSERVATION ANGLE PARAMETERS                             
  483. C                                                                       
  484.       GOTO 14
  485.    36 IFAR= ITMP1
  486.       NTH= ITMP2
  487.       NPH= ITMP3
  488.       IF( NTH.EQ.0) NTH=1
  489.       IF( NPH.EQ.0) NPH=1
  490.       IPD= ITMP4/10
  491.       IAVP= ITMP4- IPD*10
  492.       INOR= IPD/10
  493.       IPD= IPD- INOR*10
  494.       IAX= INOR/10
  495.       INOR= INOR- IAX*10
  496.       IF( IAX.NE.0) IAX=1
  497.       IF( IPD.NE.0) IPD=1
  498.       IF( NTH.LT.2.OR. NPH.LT.2) IAVP=0
  499.       IF( IFAR.EQ.1) IAVP=0
  500.       THETS= TMP1
  501.       PHIS= TMP2
  502.       DTH= TMP3
  503.       DPH= TMP4
  504.       RFLD= TMP5
  505.       GNOR= TMP6
  506.       IFLOW=10
  507. C                                                                       
  508. C     WRITE NUMERICAL GREEN'S FUNCTION TAPE                             
  509. C                                                                       
  510.       GOTO (41,46,53,71,78), IGO
  511.   322 IFLOW=12
  512.       IF( ICASX.EQ.0) GOTO 301
  513.       WRITE( 6,302) 
  514.       STOP
  515.   301 IRNGF= IRESRV/2
  516. C                                                                       
  517. C     EXECUTE CARD  -  CALC. INCLUDING RADIATED FIELDS                  
  518. C                                                                       
  519.       GOTO (41,46,52,52,52), IGO
  520.    37 IF( IFLOW.EQ.10.AND. ITMP1.EQ.0) GOTO 14
  521.       IF( NFRQ.EQ.1.AND. ITMP1.EQ.0.AND. IFLOW.GT.7) GOTO 14
  522.       IF( ITMP1.NE.0) GOTO 39
  523.       IF( IFLOW.GT.7) GOTO 38
  524.       IFLOW=7
  525.       GOTO 40
  526.    38 IFLOW=11
  527.       GOTO 40
  528.    39 IFAR=0
  529.       RFLD=0.
  530.       IPD=0
  531.       IAVP=0
  532.       INOR=0
  533.       IAX=0
  534.       NTH=91
  535.       NPH=1
  536.       THETS=0.
  537.       PHIS=0.
  538.       DTH=1.0
  539.       DPH=0.
  540.       IF( ITMP1.EQ.2) PHIS=90.
  541.       IF( ITMP1.NE.3) GOTO 40
  542.       NPH=2
  543.       DPH=90.
  544. C                                                                       
  545. C     END OF THE MAIN INPUT SECTION                                     
  546. C                                                                       
  547. C     BEGINNING OF THE FREQUENCY DO LOOP                                
  548. C                                                                       
  549.    40 GOTO (41,46,53,71,78), IGO
  550. C***
  551.    41 MHZ=1
  552.       IF( N.EQ.0.OR. IFRTMW.EQ.1) GOTO 406
  553.       IFRTMW=1
  554.       DO 445  I=1, N
  555.       XTEMP( I)= X( I)
  556.       YTEMP( I)= Y( I)
  557.       ZTEMP( I)= Z( I)
  558.       SITEMP( I)= SI( I)
  559.       BITEMP( I)= BI( I)
  560.   445 CONTINUE
  561.   406 IF( M.EQ.0.OR. IFRTMP.EQ.1) GOTO 407
  562.       IFRTMP=1
  563.       J= LD+1
  564.       DO 545  I=1, M
  565.       J= J-1
  566.       XTEMP( J)= X( J)
  567.       YTEMP( J)= Y( J)
  568.       ZTEMP( J)= Z( J)
  569.       BITEMP( J)= BI( J)
  570.   545 CONTINUE
  571.   407 CONTINUE
  572. C***
  573. C     CORE ALLOCATION FOR PRIMARY INTERACTON MATRIX.  (A)               
  574.       FMHZ1= FMHZ
  575.       IF( IMAT.EQ.0) CALL FBLOCK( NPEQ, NEQ, IRESRV, IRNGF, IPSYM)
  576.    42 IF( MHZ.EQ.1) GOTO 44
  577. C      FMHZ=FMHZ+DELFRQ                                                 
  578. C***
  579.       IF( IFRQ.EQ.1) GOTO 43
  580.       FMHZ= FMHZ1+( MHZ-1)* DELFRQ
  581.       GOTO 44
  582.    43 FMHZ= FMHZ* DELFRQ
  583. C***
  584.    44 FR= FMHZ/ CVEL
  585.       WLAM= CVEL/ FMHZ
  586.       WRITE( 6,145)  FMHZ, WLAM
  587.       WRITE( 6,196)  RKH
  588. C     FREQUENCY SCALING OF GEOMETRIC PARAMETERS                         
  589. C***      FMHZS=FMHZ                                                    
  590.       IF( IEXK.EQ.1) WRITE( 6,321) 
  591.       IF( N.EQ.0) GOTO 306
  592. C***
  593.       DO 45  I=1, N
  594.       X( I)= XTEMP( I)* FR
  595.       Y( I)= YTEMP( I)* FR
  596.       Z( I)= ZTEMP( I)* FR
  597.       SI( I)= SITEMP( I)* FR
  598. C***
  599.    45 BI( I)= BITEMP( I)* FR
  600.   306 IF( M.EQ.0) GOTO 307
  601.       FR2= FR* FR
  602.       J= LD+1
  603.       DO 245  I=1, M
  604. C***
  605.       J= J-1
  606.       X( J)= XTEMP( J)* FR
  607.       Y( J)= YTEMP( J)* FR
  608.       Z( J)= ZTEMP( J)* FR
  609. C***
  610.   245 BI( J)= BITEMP( J)* FR2
  611. C     STRUCTURE SEGMENT LOADING                                         
  612.   307 IGO=2
  613.    46 WRITE( 6,146) 
  614.       IF( NLOAD.NE.0) CALL LOAD( LDTYP, LDTAG, LDTAGF, LDTAGT, ZLR, ZLI
  615.      &, ZLC)
  616.       IF( NLOAD.EQ.0.AND. NLODF.EQ.0) WRITE( 6,147) 
  617. C     GROUND PARAMETER                                                  
  618.       IF( NLOAD.EQ.0.AND. NLODF.NE.0) WRITE( 6,327) 
  619.       WRITE( 6,148) 
  620.       IF( KSYMP.EQ.1) GOTO 49
  621.       FRATI=(1.,0.)
  622.       IF( IPERF.EQ.1) GOTO 48
  623.       IF( SIG.LT.0.) SIG=- SIG/(59.96* WLAM)
  624.       EPSC= CMPLX( EPSR,- SIG* WLAM*59.96)
  625.       ZRATI=1./ SQRT( EPSC)
  626.       U= ZRATI
  627.       U2= U* U
  628.       IF( NRADL.EQ.0) GOTO 47
  629.       SCRWL= SCRWLT/ WLAM
  630.       SCRWR= SCRWRT/ WLAM
  631.       T1= FJ*2367.067D+0/ DFLOAT( NRADL)
  632.       T2= SCRWR* DFLOAT( NRADL)
  633.       WRITE( 6,170)  NRADL, SCRWLT, SCRWRT
  634.       WRITE( 6,149) 
  635.    47 IF( IPERF.EQ.2) GOTO 328
  636.       WRITE( 6,391) 
  637.       GOTO 329
  638.   328 IF( NXA(1).EQ.0) READ( 21)  AR1, AR2, AR3, EPSCF, DXA, DYA, XSA, 
  639.      &YSA, NXA, NYA
  640.       FRATI=( EPSC-1.)/( EPSC+1.)
  641.       IF( ABS(( EPSCF- EPSC)/ EPSC).LT.1.D-3) GOTO 400
  642.       WRITE( 6,393)  EPSCF, EPSC
  643.       STOP
  644.   400 WRITE( 6,392) 
  645.   329 WRITE( 6,150)  EPSR, SIG, EPSC
  646.       GOTO 50
  647.    48 WRITE( 6,151) 
  648.       GOTO 50
  649.    49 WRITE( 6,152) 
  650. C * * *                                                                 
  651. C     FILL AND FACTOR PRIMARY INTERACTION MATRIX                        
  652. C                                                                       
  653.    50 CONTINUE
  654.       CALL SECNDS( TIM1)
  655.       IF( ICASX.NE.0) GOTO 324
  656.       CALL CMSET( NEQ, CM, RKH, IEXK)
  657.       CALL SECNDS( TIM2)
  658.       TIM= TIM2- TIM1
  659.       CALL FACTRS( NPEQ, NEQ, CM, IP, IX,11,12,13,14)
  660. C                                                                       
  661. C     N.G.F. - FILL B, C, AND D AND FACTOR D-C(INV(A)B)                 
  662. C                                                                       
  663. C ****
  664.       GOTO 323
  665. C ****
  666.   324 IF( NEQ2.EQ.0) GOTO 333
  667.       CALL CMNGF( CM( IB11), CM( IC11), CM( ID11), NPBX, NEQ, NEQ2, RKH
  668.      &, IEXK)
  669.       CALL SECNDS( TIM2)
  670.       TIM= TIM2- TIM1
  671.       CALL FACGF( CM, CM( IB11), CM( IC11), CM( ID11), CM( IX11), IP, 
  672.      &IX, NP, N1, MP, M1, NEQ, NEQ2)
  673.   323 CALL SECNDS( TIM1)
  674.       TIM2= TIM1- TIM2
  675.       WRITE( 6,153)  TIM, TIM2
  676.   333 IGO=3
  677.       NTSOL=0
  678. C     WRITE N.G.F. FILE                                                 
  679.       IF( IFLOW.NE.12) GOTO 53
  680.    52 CALL GFOUT
  681. C                                                                       
  682. C     EXCITATION SET UP (RIGHT HAND SIDE, -E INC.)                      
  683. C                                                                       
  684.       GOTO 14
  685.    53 NTHIC=1
  686.       NPHIC=1
  687.       INC=1
  688.       NPRINT=0
  689.    54 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) GOTO 56
  690.       IF( IPTFLG.LE.0.OR. IXTYP.EQ.4) WRITE( 6,154) 
  691.       TMP5= TA* XPR5
  692.       TMP4= TA* XPR4
  693.       IF( IXTYP.NE.4) GOTO 55
  694.       TMP1= XPR1/ WLAM
  695.       TMP2= XPR2/ WLAM
  696.       TMP3= XPR3/ WLAM
  697.       TMP6= XPR6/( WLAM* WLAM)
  698.       WRITE( 6,156)  XPR1, XPR2, XPR3, XPR4, XPR5, XPR6
  699.       GOTO 56
  700.    55 TMP1= TA* XPR1
  701.       TMP2= TA* XPR2
  702.       TMP3= TA* XPR3
  703.       TMP6= XPR6
  704.       IF( IPTFLG.LE.0) WRITE( 6,155)  XPR1, XPR2, XPR3, HPOL( IXTYP), 
  705.      &XPR6
  706. C                                                                       
  707. C     MATRIX SOLVING  (NETWK CALLS SOLVES)                              
  708. C                                                                       
  709.    56 CALL ETMNS( TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, IXTYP, CUR)
  710.       IF( NONET.EQ.0.OR. INC.GT.1) GOTO 60
  711.       WRITE( 6,158) 
  712.       ITMP3=0
  713.       ITMP1= NTYP(1)
  714.       DO 59  I=1,2
  715.       IF( ITMP1.EQ.3) ITMP1=2
  716.       IF( ITMP1.EQ.2) WRITE( 6,159) 
  717.       IF( ITMP1.EQ.1) WRITE( 6,160) 
  718.       DO 58  J=1, NONET
  719.       ITMP2= NTYP( J)
  720.       IF(( ITMP2/ ITMP1).EQ.1) GOTO 57
  721.       ITMP3= ITMP2
  722.       GOTO 58
  723.    57 ITMP4= ISEG1( J)
  724.       ITMP5= ISEG2( J)
  725.       IF( ITMP2.GE.2.AND. X11I( J).LE.0.) X11I( J)= WLAM* SQRT(( X( 
  726.      &ITMP5)- X( ITMP4))**2+( Y( ITMP5)- Y( ITMP4))**2+( Z( ITMP5)- Z( 
  727.      &ITMP4))**2)
  728.       WRITE( 6,157)  ITAG( ITMP4), ITMP4, ITAG( ITMP5), ITMP5, X11R( J)
  729.      &, X11I( J), X12R( J), X12I( J), X22R( J), X22I( J), PNET(2* ITMP2
  730.      &-1), PNET(2* ITMP2)
  731.    58 CONTINUE
  732.       IF( ITMP3.EQ.0) GOTO 60
  733.       ITMP1= ITMP3
  734.    59 CONTINUE
  735.    60 CONTINUE
  736.       IF( INC.GT.1.AND. IPTFLG.GT.0) NPRINT=1
  737.       CALL NETWK( CM, CM( IB11), CM( IC11), CM( ID11), IP, CUR)
  738.       NTSOL=1
  739.       IF( IPED.EQ.0) GOTO 61
  740.       ITMP1= MHZ+4*( MHZ-1)
  741.       IF( ITMP1.GT.( NORMF-3)) GOTO 61
  742.       FNORM( ITMP1)= REAL( ZPED)
  743.       FNORM( ITMP1+1)= AIMAG( ZPED)
  744.       FNORM( ITMP1+2)= ABS( ZPED)
  745.       FNORM( ITMP1+3)= CANG( ZPED)
  746.       IF( IPED.EQ.2) GOTO 61
  747.       IF( FNORM( ITMP1+2).GT. ZPNORM) ZPNORM= FNORM( ITMP1+2)
  748. C                                                                       
  749. C     PRINTING STRUCTURE CURRENTS                                       
  750. C                                                                       
  751.    61 CONTINUE
  752.       IF( N.EQ.0) GOTO 308
  753.       IF( IPTFLG.EQ.(-1)) GOTO 63
  754.       IF( IPTFLG.GT.0) GOTO 62
  755.       WRITE( 6,161) 
  756.       WRITE( 6,162) 
  757.       GOTO 63
  758.    62 IF( IPTFLG.EQ.3.OR. INC.GT.1) GOTO 63
  759.       WRITE( 6,163)  XPR3, HPOL( IXTYP), XPR6
  760.    63 PLOSS=0.
  761.       ITMP1=0
  762.       JUMP= IPTFLG+1
  763.       DO 69  I=1, N
  764.       CURI= CUR( I)* WLAM
  765.       CMAG= ABS( CURI)
  766.       PH= CANG( CURI)
  767.       IF( NLOAD.EQ.0.AND. NLODF.EQ.0) GOTO 64
  768.       IF( ABS( REAL( ZARRAY( I))).LT.1.D-20) GOTO 64
  769.       PLOSS= PLOSS+.5* CMAG* CMAG* REAL( ZARRAY( I))* SI( I)
  770.    64 IF( JUMP) 68,69,65
  771.    65 IF( IPTAG.EQ.0) GOTO 66
  772.       IF( ITAG( I).NE. IPTAG) GOTO 69
  773.    66 ITMP1= ITMP1+1
  774.       IF( ITMP1.LT. IPTAGF.OR. ITMP1.GT. IPTAGT) GOTO 69
  775.       IF( IPTFLG.EQ.0) GOTO 68
  776.       IF( IPTFLG.LT.2.OR. INC.GT. NORMF) GOTO 67
  777.       FNORM( INC)= CMAG
  778.       ISAVE= I
  779.    67 IF( IPTFLG.NE.3) WRITE( 6,164)  XPR1, XPR2, CMAG, PH, I
  780.       GOTO 69
  781. C***
  782.    68 WRITE( 6,165)  I, ITAG( I), X( I), Y( I), Z( I), SI( I), CURI, 
  783.      &CMAG, PH
  784.       IF( IPLP1.NE.1) GOTO 69
  785.       IF( IPLP2.EQ.1) WRITE( 8,*)  CURI
  786. C***
  787.       IF( IPLP2.EQ.2) WRITE( 8,*)  CMAG, PH
  788.    69 CONTINUE
  789.       IF( IPTFLQ.EQ.(-1)) GOTO 308
  790.       WRITE( 6,315) 
  791.       ITMP1=0
  792.       FR=1.D-6/ FMHZ
  793.       DO 316  I=1, N
  794.       IF( IPTFLQ.EQ.(-2)) GOTO 318
  795.       IF( IPTAQ.EQ.0) GOTO 317
  796.       IF( ITAG( I).NE. IPTAQ) GOTO 316
  797.   317 ITMP1= ITMP1+1
  798.       IF( ITMP1.LT. IPTAQF.OR. ITMP1.GT. IPTAQT) GOTO 316
  799.   318 CURI= FR* CMPLX(- BII( I), BIR( I))
  800.       CMAG= ABS( CURI)
  801.       PH= CANG( CURI)
  802.       WRITE( 6,165)  I, ITAG( I), X( I), Y( I), Z( I), SI( I), CURI, 
  803.      &CMAG, PH
  804.   316 CONTINUE
  805.   308 IF( M.EQ.0) GOTO 310
  806.       WRITE( 6,197) 
  807.       J= N-2
  808.       ITMP1= LD+1
  809.       DO 309  I=1, M
  810.       J= J+3
  811.       ITMP1= ITMP1-1
  812.       EX= CUR( J)
  813.       EY= CUR( J+1)
  814.       EZ= CUR( J+2)
  815.       ETH= EX* T1X( ITMP1)+ EY* T1Y( ITMP1)+ EZ* T1Z( ITMP1)
  816.       EPH= EX* T2X( ITMP1)+ EY* T2Y( ITMP1)+ EZ* T2Z( ITMP1)
  817.       ETHM= ABS( ETH)
  818.       ETHA= CANG( ETH)
  819.       EPHM= ABS( EPH)
  820. C309   WRITE(6,198) I,X(ITMP1),Y(ITMP1),Z(ITMP1),ETHM,ETHA,EPHM,EPHA,E  
  821. C     1X,EY, EZ                                                         
  822. C***
  823.       EPHA= CANG( EPH)
  824.       WRITE( 6,198)  I, X( ITMP1), Y( ITMP1), Z( ITMP1), ETHM, ETHA, 
  825.      &EPHM, EPHA, EX, EY, EZ
  826.       IF( IPLP1.NE.1) GOTO 309
  827.       IF( IPLP3.EQ.1) WRITE( 8,*)  EX
  828.       IF( IPLP3.EQ.2) WRITE( 8,*)  EY
  829.       IF( IPLP3.EQ.3) WRITE( 8,*)  EZ
  830.       IF( IPLP3.EQ.4) WRITE( 8,*)  EX, EY, EZ
  831. C***
  832.   309 CONTINUE
  833.   310 IF( IXTYP.NE.0.AND. IXTYP.NE.5) GOTO 70
  834.       TMP1= PIN- PNLS- PLOSS
  835.       TMP2=100.* TMP1/ PIN
  836.       WRITE( 6,166)  PIN, TMP1, PLOSS, PNLS, TMP2
  837.    70 CONTINUE
  838.       IGO=4
  839.       IF( NCOUP.GT.0) CALL COUPLE( CUR, WLAM)
  840.       IF( IFLOW.NE.7) GOTO 71
  841.       IF( IXTYP.GT.0.AND. IXTYP.LT.4) GOTO 113
  842.       IF( NFRQ.NE.1) GOTO 120
  843.       WRITE( 6,135) 
  844.       GOTO 14
  845. C                                                                       
  846. C     NEAR FIELD CALCULATION                                            
  847. C                                                                       
  848.    71 IGO=5
  849.    72 IF( NEAR.EQ.(-1)) GOTO 78
  850.       CALL NFPAT
  851.       IF( MHZ.EQ. NFRQ) NEAR=-1
  852.       IF( NFRQ.NE.1) GOTO 78
  853.       WRITE( 6,135) 
  854. C                                                                       
  855. C     STANDARD FAR FIELD CALCULATION                                    
  856. C                                                                       
  857.       GOTO 14
  858.    78 IF( IFAR.EQ.-1) GOTO 113
  859.       PINR= PIN
  860.       PNLR= PNLS
  861.       CALL RDPAT
  862.   113 IF( IXTYP.EQ.0.OR. IXTYP.GE.4) GOTO 119
  863.       NTHIC= NTHIC+1
  864.       INC= INC+1
  865.       XPR1= XPR1+ XPR4
  866.       IF( NTHIC.LE. NTHI) GOTO 54
  867.       NTHIC=1
  868.       XPR1= THETIS
  869.       XPR2= XPR2+ XPR5
  870.       NPHIC= NPHIC+1
  871.       IF( NPHIC.LE. NPHI) GOTO 54
  872.       NPHIC=1
  873.       XPR2= PHISS
  874. C     NORMALIZED RECEIVING PATTERN PRINTED                              
  875.       IF( IPTFLG.LT.2) GOTO 119
  876.       ITMP1= NTHI* NPHI
  877.       IF( ITMP1.LE. NORMF) GOTO 114
  878.       ITMP1= NORMF
  879.       WRITE( 6,181) 
  880.   114 TMP1= FNORM(1)
  881.       DO 115  J=2, ITMP1
  882.       IF( FNORM( J).GT. TMP1) TMP1= FNORM( J)
  883.   115 CONTINUE
  884.       WRITE( 6,182)  TMP1, XPR3, HPOL( IXTYP), XPR6, ISAVE
  885.       DO 118  J=1, NPHI
  886.       ITMP2= NTHI*( J-1)
  887.       DO 116  I=1, NTHI
  888.       ITMP3= I+ ITMP2
  889.       IF( ITMP3.GT. ITMP1) GOTO 117
  890.       TMP2= FNORM( ITMP3)/ TMP1
  891.       TMP3= DB20( TMP2)
  892.       WRITE( 6,183)  XPR1, XPR2, TMP3, TMP2
  893.       XPR1= XPR1+ XPR4
  894.   116 CONTINUE
  895.   117 XPR1= THETIS
  896.       XPR2= XPR2+ XPR5
  897.   118 CONTINUE
  898.       XPR2= PHISS
  899.   119 IF( MHZ.EQ. NFRQ) IFAR=-1
  900.       IF( NFRQ.NE.1) GOTO 120
  901.       WRITE( 6,135) 
  902.       GOTO 14
  903.   120 MHZ= MHZ+1
  904.       IF( MHZ.LE. NFRQ) GOTO 42
  905.       IF( IPED.EQ.0) GOTO 123
  906.       IF( NVQD.LT.1) GOTO 199
  907.       WRITE( 6,184)  IVQD( NVQD), ZPNORM
  908.       GOTO 204
  909.   199 WRITE( 6,184)  ISANT( NSANT), ZPNORM
  910.   204 ITMP1= NFRQ
  911.       IF( ITMP1.LE.( NORMF/4)) GOTO 121
  912.       ITMP1= NORMF/4
  913.       WRITE( 6,185) 
  914.   121 IF( IFRQ.EQ.0) TMP1= FMHZ-( NFRQ-1)* DELFRQ
  915.       IF( IFRQ.EQ.1) TMP1= FMHZ/( DELFRQ**( NFRQ-1))
  916.       DO 122  I=1, ITMP1
  917.       ITMP2= I+4*( I-1)
  918.       TMP2= FNORM( ITMP2)/ ZPNORM
  919.       TMP3= FNORM( ITMP2+1)/ ZPNORM
  920.       TMP4= FNORM( ITMP2+2)/ ZPNORM
  921.       TMP5= FNORM( ITMP2+3)
  922.       WRITE( 6,186)  TMP1, FNORM( ITMP2), FNORM( ITMP2+1), FNORM( ITMP2
  923.      &+2), FNORM( ITMP2+3), TMP2, TMP3, TMP4, TMP5
  924.       IF( IFRQ.EQ.0) TMP1= TMP1+ DELFRQ
  925.       IF( IFRQ.EQ.1) TMP1= TMP1* DELFRQ
  926.   122 CONTINUE
  927.       WRITE( 6,135) 
  928.   123 CONTINUE
  929.       NFRQ=1
  930.       MHZ=1
  931.       GOTO 14
  932.   125 FORMAT(A2,19A4)
  933.   126 FORMAT('1')
  934.   127 FORMAT(///,33X,'************************************',//,36X,
  935.      &'NUMERICAL ELECTROMAGNETICS CODE',//,33X,
  936.      &'************************************')
  937.   128 FORMAT(////,37X,'- - - - COMMENTS - - - -',//)
  938.   129 FORMAT(25X,20A4)
  939.   130 FORMAT(///,10X,'INCORRECT LABEL FOR A COMMENT CARD')
  940.   135 FORMAT(/////)
  941.   136 FORMAT(A2,I3,3I5,6E10.3)
  942.   137 FORMAT(1X,'***** DATA CARD NO.',I3,3X,A2,1X,I3,3(1X,I5),6(1X,1P,E
  943.      &12.5))
  944.   138 FORMAT(///,10X,'FAULTY DATA CARD LABEL AFTER GEOMETRY SECTION')
  945.   139 FORMAT(///,10X,'NUMBER OF LOADING CARDS EXCEEDS STORAGE ALLOTTED'
  946.      &)
  947.   140 FORMAT(///,10X,'DATA FAULT ON LOADING CARD NO.=',I5,5X,'ITAG S',
  948.      &'TEP1=',I5,'  IS GREATER THAN ITAG STEP2=',I5)
  949.   141 FORMAT(///,10X,'NUMBER OF EXCITATION CARDS EXCEEDS STORAGE ALLO',
  950.      &'TTED')
  951.   142 FORMAT(///,10X,'NUMBER OF NETWORK CARDS EXCEEDS STORAGE ALLOTTED'
  952.      &)
  953.   143 FORMAT(///,10X,'WHEN MULTIPLE FREQUENCIES ARE REQUESTED, ONLY ONE 
  954.      & NEAR FIELD CARD CAN BE USED -',/,10X,'LAST CARD READ IS USED')
  955.   145 FORMAT(////,33X,'- - - - - - FREQUENCY - - - - - -',//,36X,'FR',
  956.      &'EQUENCY=',1P,E11.4,' MHZ',/,36X,'WAVELENGTH=',E11.4,' METERS')
  957.   146 FORMAT(///,30X,' - - - STRUCTURE IMPEDANCE LOADING - - -')
  958.   147 FORMAT(/,35X,'THIS STRUCTURE IS NOT LOADED')
  959.   148 FORMAT(///,34X,'- - - ANTENNA ENVIRONMENT - - -',/)
  960.   149 FORMAT(40X,'MEDIUM UNDER SCREEN -')
  961.   150 FORMAT(40X,'RELATIVE DIELECTRIC CONST.=',F7.3,/,40X,'CONDUCTIV',
  962.      &'ITY=',1P,E10.3,' MHOS/METER',/,40X,
  963.      &'COMPLEX DIELECTRIC CONSTANT=',2E12.5)
  964.   151 FORMAT(42X,'PERFECT GROUND')
  965.   152 FORMAT(44X,'FREE SPACE')
  966.   153 FORMAT(///,32X,'- - - MATRIX TIMING - - -',//,24X,'FILL=',F9.3,
  967.      &' SEC.,  FACTOR=',F9.3,' SEC.')
  968.   154 FORMAT(///,40X,'- - - EXCITATION - - -')
  969.   155 FORMAT(/,4X,'PLANE WAVE',4X,'THETA=',F7.2,' DEG,  PHI=',F7.2,
  970.      &' DEG,  ETA=',F7.2,' DEG,  TYPE -',A6,'=  AXIAL RATIO=',F6.3)
  971.   156 FORMAT(/,31X,'POSITION (METERS)',14X,'ORIENTATION (DEG)=/',28X,
  972.      &'X',12X,'Y',12X,'Z',10X,'ALPHA',5X,'BETA',4X,'DIPOLE MOMENT',//,4
  973.      &X,'CURRENT SOURCE',1X,3(3X,F10.5),1X,2(3X,F7.2),4X,F8.3)
  974.   157 FORMAT(4X,4(I5,1X),1P,6(3X,E11.4),3X,A6,A2)
  975.   158 FORMAT(///,44X,'- - - NETWORK DATA - - -')
  976.   159 FORMAT(/,6X,'- FROM -    - TO -',11X,'TRANSMISSION LINE',15X,
  977.      &'-  -  SHUNT ADMITTANCES (MHOS)  -  -',14X,'LINE',/,6X,
  978.      &'TAG  SEG.','   TAG  SEG.',6X,'IMPEDANCE',6X,'LENGTH',12X,
  979.      &'- END ONE -',17X,'- END TWO -',12X,'TYPE',/,6X,
  980.      &'NO.   NO.   NO.   NO.',9X,'OHM''S',8X,'METERS',9X,'REAL',10X,
  981.      &'IMAG.',9X,'REAL',10X,'IMAG.')
  982.   160 FORMAT(/,6X,'- FROM -',4X,'- TO -',26X,'-  -  ADMITTANCE MATRIX',
  983.      &' ELEMENTS (MHOS)  -  -',/,6X,'TAG  SEG.   TAG  SEG.',13X,'(ON',
  984.      &'E,ONE)',19X,'(ONE,TWO)',19X,'(TWO,TWO)',/,6X,'NO.   NO.   NO.',
  985.      &'   NO.',8X,'REAL',10X,'IMAG.',9X,'REAL',10X,'IMAG.',9X,'REAL',10
  986.      &X,'IMAG.')
  987.   161 FORMAT(///,29X,'- - - CURRENTS AND LOCATION - - -',//,33X,'DIS',
  988.      &'TANCES IN WAVELENGTHS')
  989.   162 FORMAT(//,2X,'SEG.',2X,'TAG',4X,'COORD. OF SEG. CENTER',5X,'SEG.'
  990.      &,12X,'- - - CURRENT (AMPS) - - -',/,2X,'NO.',3X,'NO.',5X,'X',8X,
  991.      &'Y',8X,'Z',6X,'LENGTH',5X,'REAL',8X,'IMAG.',7X,'MAG.',8X,'PHASE')
  992.   163 FORMAT(///,33X,'- - - RECEIVING PATTERN PARAMETERS - - -',/,43X,
  993.      &'ETA=',F7.2,' DEGREES',/,43X,'TYPE -',A6,/,43X,'AXIAL RATIO=',F6.
  994.      &3,//,11X,'THETA',6X,'PHI',10X,'-  CURRENT  -',9X,'SEG',/,11X,
  995.      &'(DEG)',5X,'(DEG)',7X,'MAGNITUDE',4X,'PHASE',6X,'NO.',/)
  996.   164 FORMAT(10X,2(F7.2,3X),1X,1P,E11.4,3X,0P,F7.2,4X,I5)
  997.   165 FORMAT(1X,2I5,3F9.4,F9.5,1X,1P,3E12.4,0P,F9.3)
  998.   166 FORMAT(///,40X,'- - - POWER BUDGET - - -',//,43X,'INPUT PO',
  999.      &'WER   =',1P,E11.4,' WATTS',/,43X,'RADIATED POWER=',E11.4,
  1000.      &' WATTS',/,43X,'STRUCTURE LOSS=',E11.4,' WATTS',/,43X,
  1001.      &'NETWORK LOSS  =',E11.4,' WATTS',/,43X,'EFFICIENCY    =',0P,F7.2,
  1002.      &' PERCENT')
  1003.   170 FORMAT(40X,'RADIAL WIRE GROUND SCREEN',/,40X,I5,' WIRES',/,40X,
  1004.      &'WIRE LENGTH=',F8.2,' METERS',/,40X,'WIRE RADIUS=',1P,E10.3,
  1005.      &' METERS')
  1006.   181 FORMAT(///,4X,'RECEIVING PATTERN STORAGE TOO SMALL,ARRAY TRUNCA',
  1007.      &'TED')
  1008.   182 FORMAT(///,32X,'- - - NORMALIZED RECEIVING PATTERN - - -',/,41X,
  1009.      &'NORMALIZATION FACTOR=',1P,E11.4,/,41X,'ETA=',0P,F7.2,' DEGREES',
  1010.      &/,41X,'TYPE -',A6,/,41X,'AXIAL RATIO=',F6.3,/,41X,'SEGMENT NO.=',
  1011.      &I5,//,21X,'THETA',6X,'PHI',9X,'-  PATTERN  -',/,21X,'(DEG)',5X,
  1012.      &'(DEG)',8X,'DB',8X,'MAGNITUDE',/)
  1013.   183 FORMAT(20X,2(F7.2,3X),1X,F7.2,4X,1P,E11.4)
  1014.   184 FORMAT(///,36X,'- - - INPUT IMPEDANCE DATA - - -',/,45X,'SO',
  1015.      &'URCE SEGMENT NO.',I4,/,45X,'NORMALIZATION FACTOR=',1P,E12.5,//,7
  1016.      &X,'FREQ.',13X,'-  -  UNNORMALIZED IMPEDANCE  -  -',21X,'-'
  1017.      &' -  NORMALIZED IMPEDANCE  -  -',/,19X,'RESISTANCE',4X,'REACTA',
  1018.      &'NCE',6X,'MAGNITUDE',4X,'PHASE',7X,'RESISTANCE',4X,'REACTANCE',6X
  1019.      &,'MAGNITUDE',4X,'PHASE',/,8X,'MHZ',11X,'OHMS',10X,'OHMS',11X,
  1020.      &'OHMS',5X,'DEGREES',47X,'DEGREES',/)
  1021.   185 FORMAT(///,4X,'STORAGE FOR IMPEDANCE NORMALIZATION TOO SMALL, A',
  1022.      &'RRAY TRUNCATED')
  1023.   186 FORMAT(3X,F9.3,2X,1P,2(2X,E12.5),3X,E12.5,2X,0P,F7.2,2X,1P,2(2X,E
  1024.      &12.5),3X,E12.5,2X,0P,F7.2)
  1025.   196 FORMAT(////,20X,'APPROXIMATE INTEGRATION EMPLOYED FOR SEGMENT',
  1026.      &'S MORE THAN',F8.3,' WAVELENGTHS APART')
  1027.   197 FORMAT(////,41X,'- - - - SURFACE PATCH CURRENTS - - - -',//,50X,
  1028.      &'DISTANCE IN WAVELENGTHS',/,50X,'CURRENT IN AMPS/METER',//,28X,
  1029.      &'- - SURFACE COMPONENTS - -',19X,'- - - RECTANGULAR COM',
  1030.      &'PONENTS - - -',/,6X,'PATCH CENTER',6X,'TANGENT VECTOR 1',3X,
  1031.      &'TANGENT VECTOR 2',11X,'X',19X,'Y',19X,'Z',/,5X,'X',6X,'Y',6X,'Z'
  1032.      &,5X,'MAG.',7X,'PHASE',3X,'MAG.',7X,'PHASE',3(4X,'REAL',6X,'IMAG.'
  1033.      &))
  1034.   198 FORMAT(1X,I4,/,1X,3F7.3,2(1P,E11.4,0P,F8.2),1P,6E10.2)
  1035.   201 FORMAT(/,' RUN TIME =',F10.3)
  1036.   315 FORMAT(///,34X,'- - - CHARGE DENSITIES - - -',//,36X,
  1037.      &'DISTANCES IN WAVELENGTHS',///,2X,'SEG.',2X,'TAG',4X,
  1038.      &'COORD. OF SEG. CENTER',5X,'SEG.',10X,
  1039.      &'CHARGE DENSITY (COULOMBS/METER)',/,2X,'NO.',3X,'NO.',5X,'X',8X,
  1040.      &'Y',8X,'Z',6X,'LENGTH',5X,'REAL',8X,'IMAG.',7X,'MAG.',8X,'PHASE')
  1041.      &
  1042.   321 FORMAT(/,20X,'THE EXTENDED THIN WIRE KERNEL WILL BE USED')
  1043.   303 FORMAT(/,' ERROR - ',A2,' CARD IS NOT ALLOWED WITH N.G.F.')
  1044.   327 FORMAT(/,35X,' LOADING ONLY IN N.G.F. SECTION')
  1045.   302 FORMAT(' ERROR - N.G.F. IN USE.  CANNOT WRITE NEW N.G.F.')
  1046.   313 FORMAT(/,' NUMBER OF SEGMENTS IN COUPLING CALCULATION (CP) EXCEE'
  1047.      &,'DS LIMIT')
  1048.   390 FORMAT(' RADIAL WIRE G. S. APPROXIMATION MAY NOT BE USED WITH SO'
  1049.      &,'MMERFELD GROUND OPTION')
  1050.   391 FORMAT(40X,'FINITE GROUND.  REFLECTION COEFFICIENT APPROXIMATION'
  1051.      &)
  1052.   392 FORMAT(40X,'FINITE GROUND.  SOMMERFELD SOLUTION')
  1053.   393 FORMAT(/,' ERROR IN GROUND PARAMETERS -',/,' COMPLEX DIELECTRIC',
  1054.      &' CONSTANT FROM FILE IS',1P,2E12.5,/,32X,'REQUESTED',2E12.5)
  1055.       END
  1056. C ***
  1057. C     DOUBLE PRECISION 6/4/85
  1058. C
  1059.       SUBROUTINE ARC( ITG, NS, RADA, ANG1, ANG2, RAD)
  1060. C ***
  1061. C                                                                       
  1062. C     ARC GENERATES SEGMENT GEOMETRY DATA FOR AN ARC OF NS SEGMENTS     
  1063. C                                                                       
  1064.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1065.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  1066.       DIMENSION  X2(1), Y2(1), Z2(1)
  1067.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  1068.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  1069.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  1070.       EQUIVALENCE(X2,SI),(Y2,ALP),(Z2,BET)
  1071.       DATA   TA/.01745329252D+0/
  1072.       IST= N+1
  1073.       N= N+ NS
  1074.       NP= N
  1075.       MP= M
  1076.       IPSYM=0
  1077.       IF( NS.LT.1) RETURN
  1078.       IF( ABS( ANG2- ANG1).LT.360.00001D+0) GOTO 1
  1079.       WRITE( 6,3) 
  1080.       STOP
  1081.     1 ANG= ANG1* TA
  1082.       DANG=( ANG2- ANG1)* TA/ NS
  1083.       XS1= RADA* COS( ANG)
  1084.       ZS1= RADA* SIN( ANG)
  1085.       DO 2  I= IST, N
  1086.       ANG= ANG+ DANG
  1087.       XS2= RADA* COS( ANG)
  1088.       ZS2= RADA* SIN( ANG)
  1089.       X( I)= XS1
  1090.       Y( I)=0.
  1091.       Z( I)= ZS1
  1092.       X2( I)= XS2
  1093.       Y2( I)=0.
  1094.       Z2( I)= ZS2
  1095.       XS1= XS2
  1096.       ZS1= ZS2
  1097.       BI( I)= RAD
  1098.     2 ITAG( I)= ITG
  1099. C                                                                       
  1100.       RETURN
  1101.     3 FORMAT(' ERROR -- ARC ANGLE EXCEEDS 360. DEGREES')
  1102.       END
  1103. C ***
  1104. C     DOUBLE PRECISION 6/4/85
  1105. C
  1106.       FUNCTION ATGN2( X, Y)
  1107. C ***
  1108. C                                                                       
  1109. C     ATGN2 IS ARCTANGENT FUNCTION MODIFIED TO RETURN 0. WHEN X=Y=0.    
  1110. C                                                                       
  1111.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1112.       IF( X) 3,1,3
  1113.     1 IF( Y) 3,2,3
  1114.     2 ATGN2=0.
  1115.       RETURN
  1116.     3 ATGN2= ATAN2( X, Y)
  1117.       RETURN
  1118.       END
  1119. C ***
  1120. C     DOUBLE PRECISION 6/4/85
  1121. C
  1122.       SUBROUTINE BLCKOT( AR, NUNIT, IX1, IX2, NBLKS, NEOF)
  1123. C ***
  1124. C                                                                       
  1125. C     BLCKOT CONTROLS THE READING AND WRITING OF MATRIX BLOCKS ON FILES 
  1126. C     FOR THE OUT-OF-CORE MATRIX SOLUTION.                              
  1127. C                                                                       
  1128.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1129.       LOGICAL  ENF
  1130.       COMPLEX  AR
  1131.       DIMENSION  AR(1000)
  1132.       I1=( IX1+1)/2
  1133.       I2=( IX2+1)/2
  1134.     1 WRITE( NUNIT) ( AR( J), J= I1, I2)
  1135.       RETURN
  1136.       ENTRY BLCKIN( AR, NUNIT, IX1, IX2, NBLKS, NEOF)
  1137.       I1=( IX1+1)/2
  1138.       I2=( IX2+1)/2
  1139.       DO 2  I=1, NBLKS
  1140. C     IF (ENF(NUNIT)) GO TO 3                                           
  1141.       READ( NUNIT,END=3) ( AR( J), J= I1, I2)
  1142.     2 CONTINUE
  1143.       RETURN
  1144.     3 WRITE( 6,4)  NUNIT, NBLKS, NEOF
  1145.       IF( NEOF.NE.777) STOP
  1146.       NEOF=0
  1147. C                                                                       
  1148.       RETURN
  1149.     4 FORMAT('  EOF ON UNIT',I3,'  NBLKS= ',I3,'  NEOF= ',I5)
  1150.       END
  1151. C ***
  1152. C     DOUBLE PRECISION 6/4/85
  1153. C
  1154.       SUBROUTINE CABC( CURX)
  1155. C ***
  1156. C                                                                       
  1157. C     CABC COMPUTES COEFFICIENTS OF THE CONSTANT (A), SINE (B), AND     
  1158. C     COSINE (C) TERMS IN THE CURRENT INTERPOLATION FUNCTIONS FOR THE   
  1159. C     CURRENT VECTOR CUR.                                               
  1160. C                                                                       
  1161.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1162.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  1163.       COMPLEX  CUR, CURX, VQDS, CURD, CCJ, VSANT, VQD, CS1, CS2
  1164.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  1165.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  1166.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  1167.       COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM), 
  1168.      &CII( NM), CUR( N3M)
  1169.       COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50), 
  1170.      &NSCON, IPCON(10), NPCON
  1171.       COMMON  /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
  1172.      &, IQDS(30), NVQD, NSANT, NQDS
  1173.       COMMON  /ANGL/ SALP( NM)
  1174.       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  1175.       DIMENSION  CURX(1), CCJX(2)
  1176.       EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
  1177.      &T2Z,ITAG)
  1178.       EQUIVALENCE(CCJ,CCJX)
  1179.       DATA   TP/6.283185308D+0/, CCJX/0.,-0.01666666667D+0/
  1180.       IF( N.EQ.0) GOTO 6
  1181.       DO 1  I=1, N
  1182.       AIR( I)=0.
  1183.       AII( I)=0.
  1184.       BIR( I)=0.
  1185.       BII( I)=0.
  1186.       CIR( I)=0.
  1187.     1 CII( I)=0.
  1188.       DO 2  I=1, N
  1189.       AR= REAL( CURX( I))
  1190.       AI= AIMAG( CURX( I))
  1191.       CALL TBF( I,1)
  1192.       DO 2  JX=1, JSNO
  1193.       J= JCO( JX)
  1194.       AIR( J)= AIR( J)+ AX( JX)* AR
  1195.       AII( J)= AII( J)+ AX( JX)* AI
  1196.       BIR( J)= BIR( J)+ BX( JX)* AR
  1197.       BII( J)= BII( J)+ BX( JX)* AI
  1198.       CIR( J)= CIR( J)+ CX( JX)* AR
  1199.     2 CII( J)= CII( J)+ CX( JX)* AI
  1200.       IF( NQDS.EQ.0) GOTO 4
  1201.       DO 3  IS=1, NQDS
  1202.       I= IQDS( IS)
  1203.       JX= ICON1( I)
  1204.       ICON1( I)=0
  1205.       CALL TBF( I,0)
  1206.       ICON1( I)= JX
  1207.       SH= SI( I)*.5
  1208.       CURD= CCJ* VQDS( IS)/(( LOG(2.* SH/ BI( I))-1.)*( BX( JSNO)* COS(
  1209.      & TP* SH)+ CX( JSNO)* SIN( TP* SH))* WLAM)
  1210.       AR= REAL( CURD)
  1211.       AI= AIMAG( CURD)
  1212.       DO 3  JX=1, JSNO
  1213.       J= JCO( JX)
  1214.       AIR( J)= AIR( J)+ AX( JX)* AR
  1215.       AII( J)= AII( J)+ AX( JX)* AI
  1216.       BIR( J)= BIR( J)+ BX( JX)* AR
  1217.       BII( J)= BII( J)+ BX( JX)* AI
  1218.       CIR( J)= CIR( J)+ CX( JX)* AR
  1219.     3 CII( J)= CII( J)+ CX( JX)* AI
  1220.     4 DO 5  I=1, N
  1221.     5 CURX( I)= CMPLX( AIR( I)+ CIR( I), AII( I)+ CII( I))
  1222. C     CONVERT SURFACE CURRENTS FROM T1,T2 COMPONENTS TO X,Y,Z COMPONENTS
  1223.     6 IF( M.EQ.0) RETURN
  1224.       K= LD- M
  1225.       JCO1= N+2* M+1
  1226.       JCO2= JCO1+ M
  1227.       DO 7  I=1, M
  1228.       K= K+1
  1229.       JCO1= JCO1-2
  1230.       JCO2= JCO2-3
  1231.       CS1= CURX( JCO1)
  1232.       CS2= CURX( JCO1+1)
  1233.       CURX( JCO2)= CS1* T1X( K)+ CS2* T2X( K)
  1234.       CURX( JCO2+1)= CS1* T1Y( K)+ CS2* T2Y( K)
  1235.     7 CURX( JCO2+2)= CS1* T1Z( K)+ CS2* T2Z( K)
  1236.       RETURN
  1237.       END
  1238. C ***
  1239. C     DOUBLE PRECISION 6/4/85
  1240. C
  1241.       FUNCTION CANG( Z)
  1242. C ***
  1243. C                                                                       
  1244. C     CANG RETURNS THE PHASE ANGLE OF A COMPLEX NUMBER IN DEGREES.      
  1245. C                                                                       
  1246.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1247.       COMPLEX  Z
  1248.       CANG= ATGN2( AIMAG( Z), REAL( Z))*57.29577951D+0
  1249.       RETURN
  1250.       END
  1251. C ***
  1252. C     DOUBLE PRECISION 6/4/85
  1253. C
  1254.       SUBROUTINE CMNGF( CB, CC, CD, NB, NC, ND, RKHX, IEXKX)
  1255. C ***
  1256.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1257. C     CMNGF FILLS INTERACTION MATRICIES B, C, AND D FOR N.G.F. SOLUTION 
  1258.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  1259.       COMPLEX  CB, CC, CD, ZARRAY, EXK, EYK, EZK, EXS, EYS, EZS, EXC
  1260.      &, EYC, EZC
  1261.       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
  1262.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  1263.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  1264.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  1265.       COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50), 
  1266.      &NSCON, IPCON(10), NPCON
  1267.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  1268.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  1269.      &INDD2, IPGND
  1270.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  1271.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  1272.       DIMENSION  CB( NB,1), CC( NC,1), CD( ND,1)
  1273.       RKH= RKHX
  1274.       IEXK= IEXKX
  1275.       M1EQ=2* M1
  1276.       M2EQ= M1EQ+1
  1277.       MEQ=2* M
  1278.       NEQP= ND- NPCON*2
  1279.       NEQS= NEQP- NSCON
  1280.       NEQSP= NEQS+ NC
  1281.       NEQN= NC+ N- N1
  1282.       ITX=1
  1283.       IF( NSCON.GT.0) ITX=2
  1284.       IF( ICASX.EQ.1) GOTO 1
  1285.       REWIND 12
  1286.       REWIND 14
  1287.       REWIND 15
  1288.       IF( ICASX.GT.2) GOTO 5
  1289.     1 DO 4  J=1, ND
  1290.       DO 2  I=1, ND
  1291.     2 CD( I, J)=(0.,0.)
  1292.       DO 3  I=1, NB
  1293.       CB( I, J)=(0.,0.)
  1294.     3 CC( I, J)=(0.,0.)
  1295.     4 CONTINUE
  1296.     5 IST= N- N1+1
  1297.       IT= NPBX
  1298. C     LOOP THRU 24 FILLS B.  FOR ICASX=1 OR 2 ALSO FILLS D(WW), D(WS)   
  1299.       ISV=- NPBX
  1300.       DO 24  IBLK=1, NBBX
  1301.       ISV= ISV+ NPBX
  1302.       IF( IBLK.EQ. NBBX) IT= NLBX
  1303.       IF( ICASX.LT.3) GOTO 7
  1304.       DO 6  J=1, ND
  1305.       DO 6  I=1, IT
  1306.     6 CB( I, J)=(0.,0.)
  1307.     7 I1= ISV+1
  1308.       I2= ISV+ IT
  1309.       IN2= I2
  1310.       IF( IN2.GT. N1) IN2= N1
  1311.       IM1= I1- N1
  1312.       IM2= I2- N1
  1313.       IF( IM1.LT.1) IM1=1
  1314.       IMX=1
  1315.       IF( I1.LE. N1) IMX= N1- I1+2
  1316. C     FILL B(WW),B(WS).  FOR ICASX=1,2 FILL D(WW),D(WS)                 
  1317.       IF( N2.GT. N) GOTO 12
  1318.       DO 11  J= N2, N
  1319.       CALL TRIO( J)
  1320.       DO 9  I=1, JSNO
  1321.       JSS= JCO( I)
  1322. C     SET JCO WHEN SOURCE IS NEW BASIS FUNCTION ON NEW SEGMENT          
  1323.       IF( JSS.LT. N2) GOTO 8
  1324.       JCO( I)= JSS- N1
  1325. C     SOURCE IS PORTION OF MODIFIED BASIS FUNCTION ON NEW SEGMENT       
  1326.       GOTO 9
  1327.     8 JCO( I)= NEQS+ ICONX( JSS)
  1328.     9 CONTINUE
  1329.       IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CB, NB, CB, NB,0)
  1330.       IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CB( IMX,1), NB, CB, NB,0
  1331.      &)
  1332.       IF( ICASX.GT.2) GOTO 11
  1333.       CALL CMWW( J, N2, N, CD, ND, CD, ND,1)
  1334. C     LOADING IN D(WW)                                                  
  1335.       IF( M2.LE. M) CALL CMWS( J, M2EQ, MEQ, CD(1, IST), ND, CD, ND,1)
  1336.       IF( NLOAD.EQ.0) GOTO 11
  1337.       IR= J- N1
  1338.       EXK= ZARRAY( J)
  1339.       DO 10  I=1, JSNO
  1340.       JSS= JCO( I)
  1341.    10 CD( JSS, IR)= CD( JSS, IR)-( AX( I)+ CX( I))* EXK
  1342.    11 CONTINUE
  1343. C     FILL B(WW)PRIME                                                   
  1344.    12 IF( NSCON.EQ.0) GOTO 20
  1345.       DO 19  I=1, NSCON
  1346. C     SOURCES ARE NEW OR MODIFIED BASIS FUNCTIONS ON OLD SEGMENTS WHICH 
  1347. C     CONNECT TO NEW SEGMENTS                                           
  1348.       J= ISCON( I)
  1349.       CALL TRIO( J)
  1350.       JSS=0
  1351.       DO 15  IX=1, JSNO
  1352.       IR= JCO( IX)
  1353.       IF( IR.LT. N2) GOTO 13
  1354.       IR= IR- N1
  1355.       GOTO 14
  1356.    13 IR= ICONX( IR)
  1357.       IF( IR.EQ.0) GOTO 15
  1358.       IR= NEQS+ IR
  1359.    14 JSS= JSS+1
  1360.       JCO( JSS)= IR
  1361.       AX( JSS)= AX( IX)
  1362.       BX( JSS)= BX( IX)
  1363.       CX( JSS)= CX( IX)
  1364.    15 CONTINUE
  1365.       JSNO= JSS
  1366.       IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CB, NB, CB, NB,0)
  1367. C     SOURCE IS SINGULAR COMPONENT OF PATCH CURRENT THAT IS PART OF     
  1368. C     MODIFIED BASIS FUNCTION FOR OLD SEGMENT THAT CONNECTS TO A NEW    
  1369. C     SEGMENT ON END OPPOSITE PATCH.                                    
  1370.       IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CB( IMX,1), NB, CB, NB,0
  1371.      &)
  1372.       IF( I1.LE. IN2) CALL CMSW( J, I, I1, IN2, CB, CB,0, NB,-1)
  1373.       IF( NLODF.EQ.0) GOTO 17
  1374.       JX= J- ISV
  1375.       IF( JX.LT.1.OR. JX.GT. IT) GOTO 17
  1376.       EXK= ZARRAY( J)
  1377.       DO 16  IX=1, JSNO
  1378.       JSS= JCO( IX)
  1379. C     SOURCES ARE PORTIONS OF MODIFIED BASIS FUNCTION J ON OLD SEGMENTS 
  1380. C     EXCLUDING OLD SEGMENTS THAT DIRECTLY CONNECT TO NEW SEGMENTS.     
  1381.    16 CB( JX, JSS)= CB( JX, JSS)-( AX( IX)+ CX( IX))* EXK
  1382.    17 CALL TBF( J,1)
  1383.       JSX= JSNO
  1384.       JSNO=1
  1385.       IR= JCO(1)
  1386.       JCO(1)= NEQS+ I
  1387.       DO 19  IX=1, JSX
  1388.       IF( IX.EQ.1) GOTO 18
  1389.       IR= JCO( IX)
  1390.       AX(1)= AX( IX)
  1391.       BX(1)= BX( IX)
  1392.       CX(1)= CX( IX)
  1393.    18 IF( IR.GT. N1) GOTO 19
  1394.       IF( ICONX( IR).NE.0) GOTO 19
  1395.       IF( I1.LE. IN2) CALL CMWW( IR, I1, IN2, CB, NB, CB, NB,0)
  1396. C     LOADING FOR B(WW)PRIME                                            
  1397.       IF( IM1.LE. IM2) CALL CMWS( IR, IM1, IM2, CB( IMX,1), NB, CB, NB,
  1398.      &0)
  1399.       IF( NLODF.EQ.0) GOTO 19
  1400.       JX= IR- ISV
  1401.       IF( JX.LT.1.OR. JX.GT. IT) GOTO 19
  1402.       EXK= ZARRAY( IR)
  1403.       JSS= JCO(1)
  1404.       CB( JX, JSS)= CB( JX, JSS)-( AX(1)+ CX(1))* EXK
  1405.    19 CONTINUE
  1406.    20 IF( NPCON.EQ.0) GOTO 22
  1407. C     FILL B(SS)PRIME TO SET OLD PATCH BASIS FUNCTIONS TO ZERO FOR      
  1408. C     PATCHES THAT CONNECT TO NEW SEGMENTS                              
  1409.       JSS= NEQP
  1410.       DO 21  I=1, NPCON
  1411.       IX= IPCON( I)*2+ N1- ISV
  1412.       IR= IX-1
  1413.       JSS= JSS+1
  1414.       IF( IR.GT.0.AND. IR.LE. IT) CB( IR, JSS)=(1.,0.)
  1415.       JSS= JSS+1
  1416.       IF( IX.GT.0.AND. IX.LE. IT) CB( IX, JSS)=(1.,0.)
  1417.    21 CONTINUE
  1418. C     FILL B(SW) AND B(SS)                                              
  1419.    22 IF( M2.GT. M) GOTO 23
  1420.       IF( I1.LE. IN2) CALL CMSW( M2, M, I1, IN2, CB(1, IST), CB, N1, NB
  1421.      &,0)
  1422.       IF( IM1.LE. IM2) CALL CMSS( M2, M, IM1, IM2, CB( IMX, IST), NB,0)
  1423.      &
  1424.    23 IF( ICASX.EQ.1) GOTO 24
  1425.       WRITE( 14) (( CB( I, J), I=1, IT), J=1, ND)
  1426. C     FILLING B COMPLETE.  START ON C AND D                             
  1427.    24 CONTINUE
  1428.       IT= NPBL
  1429.       ISV=- NPBL
  1430.       DO 43  IBLK=1, NBBL
  1431.       ISV= ISV+ NPBL
  1432.       ISVV= ISV+ NC
  1433.       IF( IBLK.EQ. NBBL) IT= NLBL
  1434.       IF( ICASX.LT.3) GOTO 27
  1435.       DO 26  J=1, IT
  1436.       DO 25  I=1, NC
  1437.    25 CC( I, J)=(0.,0.)
  1438.       DO 26  I=1, ND
  1439.    26 CD( I, J)=(0.,0.)
  1440.    27 I1= ISVV+1
  1441.       I2= ISVV+ IT
  1442.       IN1= I1- M1EQ
  1443.       IN2= I2- M1EQ
  1444.       IF( IN2.GT. N) IN2= N
  1445.       IM1= I1- N
  1446.       IM2= I2- N
  1447.       IF( IM1.LT. M2EQ) IM1= M2EQ
  1448.       IF( IM2.GT. MEQ) IM2= MEQ
  1449.       IMX=1
  1450.       IF( IN1.LE. IN2) IMX= NEQN- I1+2
  1451.       IF( ICASX.LT.3) GOTO 32
  1452. C     SAME AS DO 24 LOOP TO FILL D(WW) FOR ICASX GREATER THAN 2         
  1453.       IF( N2.GT. N) GOTO 32
  1454.       DO 31  J= N2, N
  1455.       CALL TRIO( J)
  1456.       DO 29  I=1, JSNO
  1457.       JSS= JCO( I)
  1458.       IF( JSS.LT. N2) GOTO 28
  1459.       JCO( I)= JSS- N1
  1460.       GOTO 29
  1461.    28 JCO( I)= NEQS+ ICONX( JSS)
  1462.    29 CONTINUE
  1463.       IF( IN1.LE. IN2) CALL CMWW( J, IN1, IN2, CD, ND, CD, ND,1)
  1464.       IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CD(1, IMX), ND, CD, ND,1
  1465.      &)
  1466.       IF( NLOAD.EQ.0) GOTO 31
  1467.       IR= J- N1- ISV
  1468.       IF( IR.LT.1.OR. IR.GT. IT) GOTO 31
  1469.       EXK= ZARRAY( J)
  1470.       DO 30  I=1, JSNO
  1471.       JSS= JCO( I)
  1472.    30 CD( JSS, IR)= CD( JSS, IR)-( AX( I)+ CX( I))* EXK
  1473.    31 CONTINUE
  1474. C     FILL D(SW) AND D(SS)                                              
  1475.    32 IF( M2.GT. M) GOTO 33
  1476.       IF( IN1.LE. IN2) CALL CMSW( M2, M, IN1, IN2, CD( IST,1), CD, N1, 
  1477.      &ND,1)
  1478.       IF( IM1.LE. IM2) CALL CMSS( M2, M, IM1, IM2, CD( IST, IMX), ND,1)
  1479.      &
  1480. C     FILL C(WW),C(WS), D(WW)PRIME, AND D(WS)PRIME.                     
  1481.    33 IF( N1.LT.1) GOTO 39
  1482.       DO 37  J=1, N1
  1483.       CALL TRIO( J)
  1484.       IF( NSCON.EQ.0) GOTO 36
  1485.       DO 35  IX=1, JSNO
  1486.       JSS= JCO( IX)
  1487.       IF( JSS.LT. N2) GOTO 34
  1488.       JCO( IX)= JSS+ M1EQ
  1489.       GOTO 35
  1490.    34 IR= ICONX( JSS)
  1491.       IF( IR.NE.0) JCO( IX)= NEQSP+ IR
  1492.    35 CONTINUE
  1493.    36 IF( IN1.LE. IN2) CALL CMWW( J, IN1, IN2, CC, NC, CD, ND, ITX)
  1494.       IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CC(1, IMX), NC, CD(1, 
  1495.      &IMX), ND, ITX)
  1496.    37 CONTINUE
  1497. C     FILL C(WW)PRIME                                                   
  1498.       IF( NSCON.EQ.0) GOTO 39
  1499.       DO 38  IX=1, NSCON
  1500.       IR= ISCON( IX)
  1501.       JSS= NEQS+ IX- ISV
  1502.       IF( JSS.GT.0.AND. JSS.LE. IT) CC( IR, JSS)=(1.,0.)
  1503.    38 CONTINUE
  1504.    39 IF( NPCON.EQ.0) GOTO 41
  1505. C     FILL C(SS)PRIME                                                   
  1506.       JSS= NEQP- ISV
  1507.       DO 40  I=1, NPCON
  1508.       IX= IPCON( I)*2+ N1
  1509.       IR= IX-1
  1510.       JSS= JSS+1
  1511.       IF( JSS.GT.0.AND. JSS.LE. IT) CC( IR, JSS)=(1.,0.)
  1512.       JSS= JSS+1
  1513.       IF( JSS.GT.0.AND. JSS.LE. IT) CC( IX, JSS)=(1.,0.)
  1514.    40 CONTINUE
  1515. C     FILL C(SW) AND C(SS)                                              
  1516.    41 IF( M1.LT.1) GOTO 42
  1517.       IF( IN1.LE. IN2) CALL CMSW(1, M1, IN1, IN2, CC( N2,1), CC,0, NC,1
  1518.      &)
  1519.       IF( IM1.LE. IM2) CALL CMSS(1, M1, IM1, IM2, CC( N2, IMX), NC,1)
  1520.    42 CONTINUE
  1521.       IF( ICASX.EQ.1) GOTO 43
  1522.       WRITE( 12) (( CD( J, I), J=1, ND), I=1, IT)
  1523.       WRITE( 15) (( CC( J, I), J=1, NC), I=1, IT)
  1524.    43 CONTINUE
  1525.       IF( ICASX.EQ.1) RETURN
  1526.       REWIND 12
  1527.       REWIND 14
  1528.       REWIND 15
  1529.       RETURN
  1530.       END
  1531. C ***
  1532. C     DOUBLE PRECISION 6/4/85
  1533. C
  1534.       SUBROUTINE CMSET( NROW, CM, RKHX, IEXKX)
  1535. C ***
  1536.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1537. C                                                                       
  1538. C     CMSET SETS UP THE COMPLEX STRUCTURE MATRIX IN THE ARRAY CM        
  1539. C                                                                       
  1540.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  1541.       COMPLEX  CM, ZARRAY, ZAJ, ETK, ETS, ETC, EXK, EYK, EZK, EXS, 
  1542.      &EYS, EZS, EXC, EYC, EZC, SSX, D, DETER
  1543.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  1544.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  1545.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  1546.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  1547.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  1548.       COMMON  /SMAT/ SSX(16,16)
  1549.       COMMON  /SCRATM/ D( N2M)
  1550.       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
  1551.       COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50), 
  1552.      &NSCON, IPCON(10), NPCON
  1553.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  1554.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  1555.      &INDD2, IPGND
  1556.       DIMENSION  CM( NROW,1)
  1557.       MP2=2* MP
  1558.       NPEQ= NP+ MP2
  1559.       NEQ= N+2* M
  1560.       NOP= NEQ/ NPEQ
  1561.       IF( ICASE.GT.2) REWIND 11
  1562.       RKH= RKHX
  1563.       IEXK= IEXKX
  1564.       IOUT=2* NPBLK* NROW
  1565. C                                                                       
  1566. C     CYCLE OVER MATRIX BLOCKS                                          
  1567. C                                                                       
  1568.       IT= NPBLK
  1569.       DO 13  IXBLK1=1, NBLOKS
  1570.       ISV=( IXBLK1-1)* NPBLK
  1571.       IF( IXBLK1.EQ. NBLOKS) IT= NLAST
  1572.       DO 1  I=1, NROW
  1573.       DO 1  J=1, IT
  1574.     1 CM( I, J)=(0.,0.)
  1575.       I1= ISV+1
  1576.       I2= ISV+ IT
  1577.       IN2= I2
  1578.       IF( IN2.GT. NP) IN2= NP
  1579.       IM1= I1- NP
  1580.       IM2= I2- NP
  1581.       IF( IM1.LT.1) IM1=1
  1582.       IST=1
  1583.       IF( I1.LE. NP) IST= NP- I1+2
  1584. C                                                                       
  1585. C     WIRE SOURCE LOOP                                                  
  1586. C                                                                       
  1587.       IF( N.EQ.0) GOTO 5
  1588.       DO 4  J=1, N
  1589.       CALL TRIO( J)
  1590.       DO 2  I=1, JSNO
  1591.       IJ= JCO( I)
  1592.     2 JCO( I)=(( IJ-1)/ NP)* MP2+ IJ
  1593.       IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CM, NROW, CM, NROW,1)
  1594.       IF( IM1.LE. IM2) CALL CMWS( J, IM1, IM2, CM(1, IST), NROW, CM, 
  1595.      &NROW,1)
  1596. C                                                                       
  1597. C     MATRIX ELEMENTS MODIFIED BY LOADING                               
  1598. C                                                                       
  1599.       IF( NLOAD.EQ.0) GOTO 4
  1600.       IF( J.GT. NP) GOTO 4
  1601.       IPR= J- ISV
  1602.       IF( IPR.LT.1.OR. IPR.GT. IT) GOTO 4
  1603.       ZAJ= ZARRAY( J)
  1604.       DO 3  I=1, JSNO
  1605.       JSS= JCO( I)
  1606.     3 CM( JSS, IPR)= CM( JSS, IPR)-( AX( I)+ CX( I))* ZAJ
  1607.     4 CONTINUE
  1608. C     MATRIX ELEMENTS FOR PATCH CURRENT SOURCES                         
  1609.     5 IF( M.EQ.0) GOTO 7
  1610.       JM1=1- MP
  1611.       JM2=0
  1612.       JST=1- MP2
  1613.       DO 6  I=1, NOP
  1614.       JM1= JM1+ MP
  1615.       JM2= JM2+ MP
  1616.       JST= JST+ NPEQ
  1617.       IF( I1.LE. IN2) CALL CMSW( JM1, JM2, I1, IN2, CM( JST,1), CM,0, 
  1618.      &NROW,1)
  1619.       IF( IM1.LE. IM2) CALL CMSS( JM1, JM2, IM1, IM2, CM( JST, IST), 
  1620.      &NROW,1)
  1621.     6 CONTINUE
  1622.     7 IF( ICASE.EQ.1) GOTO 13
  1623. C     COMBINE ELEMENTS FOR SYMMETRY MODES                               
  1624.       IF( ICASE.EQ.3) GOTO 12
  1625.       DO 11  I=1, IT
  1626.       DO 11  J=1, NPEQ
  1627.       DO 8  K=1, NOP
  1628.       KA= J+( K-1)* NPEQ
  1629.     8 D( K)= CM( KA, I)
  1630.       DETER= D(1)
  1631.       DO 9  KK=2, NOP
  1632.     9 DETER= DETER+ D( KK)
  1633.       CM( J, I)= DETER
  1634.       DO 11  K=2, NOP
  1635.       KA= J+( K-1)* NPEQ
  1636.       DETER= D(1)
  1637.       DO 10  KK=2, NOP
  1638.    10 DETER= DETER+ D( KK)* SSX( K, KK)
  1639.       CM( KA, I)= DETER
  1640.    11 CONTINUE
  1641. C     WRITE BLOCK FOR OUT-OF-CORE CASES.                                
  1642.       IF( ICASE.LT.3) GOTO 13
  1643.    12 CALL BLCKOT( CM,11,1, IOUT,1,31)
  1644.    13 CONTINUE
  1645.       IF( ICASE.GT.2) REWIND 11
  1646.       RETURN
  1647.       END
  1648. C ***
  1649. C     DOUBLE PRECISION 6/4/85
  1650. C
  1651.       SUBROUTINE CMSS( J1, J2, IM1, IM2, CM, NROW, ITRP)
  1652. C ***
  1653.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1654. C     CMSS COMPUTES MATRIX ELEMENTS FOR SURFACE-SURFACE INTERACTIONS.   
  1655.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  1656.       COMPLEX  G11, G12, G21, G22, CM, EXK, EYK, EZK, EXS, EYS, EZS,
  1657.      & EXC, EYC, EZC
  1658.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  1659.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  1660.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  1661.       COMMON  /ANGL/ SALP( NM)
  1662.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  1663.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  1664.      &INDD2, IPGND
  1665.       DIMENSION  CM( NROW,1)
  1666.       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  1667.       EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
  1668.      &T2Z,ITAG)
  1669.       EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
  1670.      &IND1),(T2ZJ,IND2)
  1671.       LDP= LD+1
  1672.       I1=( IM1+1)/2
  1673.       I2=( IM2+1)/2
  1674.       ICOMP= I1*2-3
  1675.       II1=-1
  1676. C     LOOP OVER OBSERVATION PATCHES                                     
  1677.       IF( ICOMP+2.LT. IM1) II1=-2
  1678.       DO 5  I= I1, I2
  1679.       IL= LDP- I
  1680.       ICOMP= ICOMP+2
  1681.       II1= II1+2
  1682.       II2= II1+1
  1683.       T1XI= T1X( IL)* SALP( IL)
  1684.       T1YI= T1Y( IL)* SALP( IL)
  1685.       T1ZI= T1Z( IL)* SALP( IL)
  1686.       T2XI= T2X( IL)* SALP( IL)
  1687.       T2YI= T2Y( IL)* SALP( IL)
  1688.       T2ZI= T2Z( IL)* SALP( IL)
  1689.       XI= X( IL)
  1690.       YI= Y( IL)
  1691.       ZI= Z( IL)
  1692. C     LOOP OVER SOURCE PATCHES                                          
  1693.       JJ1=-1
  1694.       DO 5  J= J1, J2
  1695.       JL= LDP- J
  1696.       JJ1= JJ1+2
  1697.       JJ2= JJ1+1
  1698.       S= BI( JL)
  1699.       XJ= X( JL)
  1700.       YJ= Y( JL)
  1701.       ZJ= Z( JL)
  1702.       T1XJ= T1X( JL)
  1703.       T1YJ= T1Y( JL)
  1704.       T1ZJ= T1Z( JL)
  1705.       T2XJ= T2X( JL)
  1706.       T2YJ= T2Y( JL)
  1707.       T2ZJ= T2Z( JL)
  1708.       CALL HINTG( XI, YI, ZI)
  1709.       G11=-( T2XI* EXK+ T2YI* EYK+ T2ZI* EZK)
  1710.       G12=-( T2XI* EXS+ T2YI* EYS+ T2ZI* EZS)
  1711.       G21=-( T1XI* EXK+ T1YI* EYK+ T1ZI* EZK)
  1712.       G22=-( T1XI* EXS+ T1YI* EYS+ T1ZI* EZS)
  1713.       IF( I.NE. J) GOTO 1
  1714.       G11= G11-.5
  1715.       G22= G22+.5
  1716. C     NORMAL FILL                                                       
  1717.     1 IF( ITRP.NE.0) GOTO 3
  1718.       IF( ICOMP.LT. IM1) GOTO 2
  1719.       CM( II1, JJ1)= G11
  1720.       CM( II1, JJ2)= G12
  1721.     2 IF( ICOMP.GE. IM2) GOTO 5
  1722.       CM( II2, JJ1)= G21
  1723.       CM( II2, JJ2)= G22
  1724. C     TRANSPOSED FILL                                                   
  1725.       GOTO 5
  1726.     3 IF( ICOMP.LT. IM1) GOTO 4
  1727.       CM( JJ1, II1)= G11
  1728.       CM( JJ2, II1)= G12
  1729.     4 IF( ICOMP.GE. IM2) GOTO 5
  1730.       CM( JJ1, II2)= G21
  1731.       CM( JJ2, II2)= G22
  1732.     5 CONTINUE
  1733.       RETURN
  1734.       END
  1735. C ***
  1736. C     DOUBLE PRECISION 6/4/85
  1737. C
  1738.       SUBROUTINE CMSW( J1, J2, I1, I2, CM, CW, NCW, NROW, ITRP)
  1739. C ***
  1740.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1741. C     COMPUTES MATRIX ELEMENTS FOR E ALONG WIRES DUE TO PATCH CURRENT   
  1742.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  1743.       COMPLEX  CM, ZRATI, ZRATI2, T1, EXK, EYK, EZK, EXS, EYS, EZS, 
  1744.      &EXC, EYC, EZC, EMEL, CW, FRATI
  1745.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  1746.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  1747.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  1748.       COMMON  /ANGL/ SALP( NM)
  1749.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  1750.      &KSYMP, IFAR, IPERF, T1, T2
  1751.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  1752.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  1753.      &INDD2, IPGND
  1754.       COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50), 
  1755.      &NSCON, IPCON(10), NPCON
  1756.       DIMENSION  CAB(1), SAB(1), CM( NROW,1), CW( NROW,1)
  1757.       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), EMEL(9
  1758.      &)
  1759.       EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
  1760.      &T2Z,ITAG),(CAB,ALP),(SAB,BET)
  1761.       EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
  1762.      &IND1),(T2ZJ,IND2)
  1763.       DATA   PI/3.141592654D+0/
  1764.       LDP= LD+1
  1765.       NEQS= N- N1+2*( M- M1)
  1766.       IF( ITRP.LT.0) GOTO 13
  1767.       K=0
  1768. C     OBSERVATION LOOP                                                  
  1769.       ICGO=1
  1770.       DO 12  I= I1, I2
  1771.       K= K+1
  1772.       XI= X( I)
  1773.       YI= Y( I)
  1774.       ZI= Z( I)
  1775.       CABI= CAB( I)
  1776.       SABI= SAB( I)
  1777.       SALPI= SALP( I)
  1778.       IPCH=0
  1779.       IF( ICON1( I).LT.10000) GOTO 1
  1780.       IPCH= ICON1( I)-10000
  1781.       FSIGN=-1.
  1782.     1 IF( ICON2( I).LT.10000) GOTO 2
  1783.       IPCH= ICON2( I)-10000
  1784.       FSIGN=1.
  1785. C     SOURCE LOOP                                                       
  1786.     2 JL=0
  1787.       DO 12  J= J1, J2
  1788.       JS= LDP- J
  1789.       JL= JL+2
  1790.       T1XJ= T1X( JS)
  1791.       T1YJ= T1Y( JS)
  1792.       T1ZJ= T1Z( JS)
  1793.       T2XJ= T2X( JS)
  1794.       T2YJ= T2Y( JS)
  1795.       T2ZJ= T2Z( JS)
  1796.       XJ= X( JS)
  1797.       YJ= Y( JS)
  1798.       ZJ= Z( JS)
  1799. C     GROUND LOOP                                                       
  1800.       S= BI( JS)
  1801.       DO 12  IP=1, KSYMP
  1802.       IPGND= IP
  1803.       IF( IPCH.NE. J.AND. ICGO.EQ.1) GOTO 9
  1804.       IF( IP.EQ.2) GOTO 9
  1805.       IF( ICGO.GT.1) GOTO 6
  1806.       CALL PCINT( XI, YI, ZI, CABI, SABI, SALPI, EMEL)
  1807.       PY= PI* SI( I)* FSIGN
  1808.       PX= SIN( PY)
  1809.       PY= COS( PY)
  1810.       EXC= EMEL(9)* FSIGN
  1811.       CALL TRIO( I)
  1812.       IF( I.GT. N1) GOTO 3
  1813.       IL= NEQS+ ICONX( I)
  1814.       GOTO 4
  1815.     3 IL= I- NCW
  1816.       IF( I.LE. NP) IL=(( IL-1)/ NP)*2* MP+ IL
  1817.     4 IF( ITRP.NE.0) GOTO 5
  1818.       CW( K, IL)= CW( K, IL)+ EXC*( AX( JSNO)+ BX( JSNO)* PX+ CX( JSNO)
  1819.      &* PY)
  1820.       GOTO 6
  1821.     5 CW( IL, K)= CW( IL, K)+ EXC*( AX( JSNO)+ BX( JSNO)* PX+ CX( JSNO)
  1822.      &* PY)
  1823.     6 IF( ITRP.NE.0) GOTO 7
  1824.       CM( K, JL-1)= EMEL( ICGO)
  1825.       CM( K, JL)= EMEL( ICGO+4)
  1826.       GOTO 8
  1827.     7 CM( JL-1, K)= EMEL( ICGO)
  1828.       CM( JL, K)= EMEL( ICGO+4)
  1829.     8 ICGO= ICGO+1
  1830.       IF( ICGO.EQ.5) ICGO=1
  1831.       GOTO 11
  1832.     9 CALL UNERE( XI, YI, ZI)
  1833. C     NORMAL FILL                                                       
  1834.       IF( ITRP.NE.0) GOTO 10
  1835.       CM( K, JL-1)= CM( K, JL-1)+ EXK* CABI+ EYK* SABI+ EZK* SALPI
  1836.       CM( K, JL)= CM( K, JL)+ EXS* CABI+ EYS* SABI+ EZS* SALPI
  1837. C     TRANSPOSED FILL                                                   
  1838.       GOTO 11
  1839.    10 CM( JL-1, K)= CM( JL-1, K)+ EXK* CABI+ EYK* SABI+ EZK* SALPI
  1840.       CM( JL, K)= CM( JL, K)+ EXS* CABI+ EYS* SABI+ EZS* SALPI
  1841.    11 CONTINUE
  1842.    12 CONTINUE
  1843. C     FOR OLD SEG. CONNECTING TO OLD PATCH ON ONE END AND NEW SEG. ON   
  1844. C     OTHER END INTEGRATE SINGULAR COMPONENT (9) OF SURFACE CURRENT ONLY
  1845.       RETURN
  1846.    13 IF( J1.LT. I1.OR. J1.GT. I2) GOTO 16
  1847.       IPCH= ICON1( J1)
  1848.       IF( IPCH.LT.10000) GOTO 14
  1849.       IPCH= IPCH-10000
  1850.       FSIGN=-1.
  1851.       GOTO 15
  1852.    14 IPCH= ICON2( J1)
  1853.       IF( IPCH.LT.10000) GOTO 16
  1854.       IPCH= IPCH-10000
  1855.       FSIGN=1.
  1856.    15 IF( IPCH.GT. M1) GOTO 16
  1857.       JS= LDP- IPCH
  1858.       IPGND=1
  1859.       T1XJ= T1X( JS)
  1860.       T1YJ= T1Y( JS)
  1861.       T1ZJ= T1Z( JS)
  1862.       T2XJ= T2X( JS)
  1863.       T2YJ= T2Y( JS)
  1864.       T2ZJ= T2Z( JS)
  1865.       XJ= X( JS)
  1866.       YJ= Y( JS)
  1867.       ZJ= Z( JS)
  1868.       S= BI( JS)
  1869.       XI= X( J1)
  1870.       YI= Y( J1)
  1871.       ZI= Z( J1)
  1872.       CABI= CAB( J1)
  1873.       SABI= SAB( J1)
  1874.       SALPI= SALP( J1)
  1875.       CALL PCINT( XI, YI, ZI, CABI, SABI, SALPI, EMEL)
  1876.       PY= PI* SI( J1)* FSIGN
  1877.       PX= SIN( PY)
  1878.       PY= COS( PY)
  1879.       EXC= EMEL(9)* FSIGN
  1880.       IL= JCO( JSNO)
  1881.       K= J1- I1+1
  1882.       CW( K, IL)= CW( K, IL)+ EXC*( AX( JSNO)+ BX( JSNO)* PX+ CX( JSNO)
  1883.      &* PY)
  1884.    16 RETURN
  1885.       END
  1886. C ***
  1887. C     DOUBLE PRECISION 6/4/85
  1888. C
  1889.       SUBROUTINE CMWS( J, I1, I2, CM, NR, CW, NW, ITRP)
  1890. C ***
  1891. C                                                                       
  1892. C     CMWS COMPUTES MATRIX ELEMENTS FOR WIRE-SURFACE INTERACTIONS       
  1893. C                                                                       
  1894.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1895.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  1896.       COMPLEX  CM, CW, ETK, ETS, ETC, EXK, EYK, EZK, EXS, EYS, EZS, 
  1897.      &EXC, EYC, EZC
  1898.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  1899.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  1900.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  1901.       COMMON  /ANGL/ SALP( NM)
  1902.       COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50), 
  1903.      &NSCON, IPCON(10), NPCON
  1904.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  1905.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  1906.      &INDD2, IPGND
  1907.       DIMENSION  CM( NR,1), CW( NW,1), CAB(1), SAB(1)
  1908.       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  1909.       EQUIVALENCE(CAB,ALP),(SAB,BET),(T1X,SI),(T1Y,ALP),(T1Z,BET)
  1910.       EQUIVALENCE(T2X,ICON1),(T2Y,ICON2),(T2Z,ITAG)
  1911.       LDP= LD+1
  1912.       S= SI( J)
  1913.       B= BI( J)
  1914.       XJ= X( J)
  1915.       YJ= Y( J)
  1916.       ZJ= Z( J)
  1917.       CABJ= CAB( J)
  1918.       SABJ= SAB( J)
  1919. C                                                                       
  1920. C     OBSERVATION LOOP                                                  
  1921. C                                                                       
  1922.       SALPJ= SALP( J)
  1923.       IPR=0
  1924.       DO 9  I= I1, I2
  1925.       IPR= IPR+1
  1926.       IPATCH=( I+1)/2
  1927.       IK= I-( I/2)*2
  1928.       IF( IK.EQ.0.AND. IPR.NE.1) GOTO 1
  1929.       JS= LDP- IPATCH
  1930.       XI= X( JS)
  1931.       YI= Y( JS)
  1932.       ZI= Z( JS)
  1933.       CALL HSFLD( XI, YI, ZI,0.)
  1934.       IF( IK.EQ.0) GOTO 1
  1935.       TX= T2X( JS)
  1936.       TY= T2Y( JS)
  1937.       TZ= T2Z( JS)
  1938.       GOTO 2
  1939.     1 TX= T1X( JS)
  1940.       TY= T1Y( JS)
  1941.       TZ= T1Z( JS)
  1942.     2 ETK=-( EXK* TX+ EYK* TY+ EZK* TZ)* SALP( JS)
  1943.       ETS=-( EXS* TX+ EYS* TY+ EZS* TZ)* SALP( JS)
  1944. C                                                                       
  1945. C     FILL MATRIX ELEMENTS.  ELEMENT LOCATIONS DETERMINED BY CONNECTION 
  1946. C     DATA.                                                             
  1947. C                                                                       
  1948.       ETC=-( EXC* TX+ EYC* TY+ EZC* TZ)* SALP( JS)
  1949. C     NORMAL FILL                                                       
  1950.       IF( ITRP.NE.0) GOTO 4
  1951.       DO 3  IJ=1, JSNO
  1952.       JX= JCO( IJ)
  1953.     3 CM( IPR, JX)= CM( IPR, JX)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX( 
  1954.      &IJ)
  1955.       GOTO 9
  1956. C     TRANSPOSED FILL                                                   
  1957.     4 IF( ITRP.EQ.2) GOTO 6
  1958.       DO 5  IJ=1, JSNO
  1959.       JX= JCO( IJ)
  1960.     5 CM( JX, IPR)= CM( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX( 
  1961.      &IJ)
  1962. C     TRANSPOSED FILL - C(WS) AND D(WS)PRIME (=CW)                      
  1963.       GOTO 9
  1964.     6 DO 8  IJ=1, JSNO
  1965.       JX= JCO( IJ)
  1966.       IF( JX.GT. NR) GOTO 7
  1967.       CM( JX, IPR)= CM( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX( 
  1968.      &IJ)
  1969.       GOTO 8
  1970.     7 JX= JX- NR
  1971.       CW( JX, IPR)= CW( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX( 
  1972.      &IJ)
  1973.     8 CONTINUE
  1974.     9 CONTINUE
  1975.       RETURN
  1976.       END
  1977. C ***
  1978. C     DOUBLE PRECISION 6/4/85
  1979. C
  1980.       SUBROUTINE CMWW( J, I1, I2, CM, NR, CW, NW, ITRP)
  1981. C ***
  1982.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1983. C                                                                       
  1984. C     CMWW COMPUTES MATRIX ELEMENTS FOR WIRE-WIRE INTERACTIONS          
  1985. C                                                                       
  1986.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  1987.       COMPLEX  CM, CW, ETK, ETS, ETC, EXK, EYK, EZK, EXS, EYS, EZS, 
  1988.      &EXC, EYC, EZC
  1989.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  1990.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  1991.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  1992.       COMMON  /ANGL/ SALP( NM)
  1993.       COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50), 
  1994.      &NSCON, IPCON(10), NPCON
  1995.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  1996.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  1997.      &INDD2, IPGND
  1998.       DIMENSION  CM( NR,1), CW( NW,1), CAB(1), SAB(1)
  1999. C     SET SOURCE SEGMENT PARAMETERS                                     
  2000.       EQUIVALENCE(CAB,ALP),(SAB,BET)
  2001.       S= SI( J)
  2002.       B= BI( J)
  2003.       XJ= X( J)
  2004.       YJ= Y( J)
  2005.       ZJ= Z( J)
  2006.       CABJ= CAB( J)
  2007.       SABJ= SAB( J)
  2008.       SALPJ= SALP( J)
  2009. C     DECIDE WETHER EXT. T.W. APPROX. CAN BE USED                       
  2010.       IF( IEXK.EQ.0) GOTO 16
  2011.       IPR= ICON1( J)
  2012.       IF( IPR) 1,6,2
  2013.     1 IPR=- IPR
  2014.       IF(- ICON1( IPR).NE. J) GOTO 7
  2015.       GOTO 4
  2016.     2 IF( IPR.NE. J) GOTO 3
  2017.       IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 7
  2018.       GOTO 5
  2019.     3 IF( ICON2( IPR).NE. J) GOTO 7
  2020.     4 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
  2021.       IF( XI.LT.0.999999D+0) GOTO 7
  2022.       IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 7
  2023.     5 IND1=0
  2024.       GOTO 8
  2025.     6 IND1=1
  2026.       GOTO 8
  2027.     7 IND1=2
  2028.     8 IPR= ICON2( J)
  2029.       IF( IPR) 9,14,10
  2030.     9 IPR=- IPR
  2031.       IF(- ICON2( IPR).NE. J) GOTO 15
  2032.       GOTO 12
  2033.    10 IF( IPR.NE. J) GOTO 11
  2034.       IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 15
  2035.       GOTO 13
  2036.    11 IF( ICON1( IPR).NE. J) GOTO 15
  2037.    12 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
  2038.       IF( XI.LT.0.999999D+0) GOTO 15
  2039.       IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 15
  2040.    13 IND2=0
  2041.       GOTO 16
  2042.    14 IND2=1
  2043.       GOTO 16
  2044.    15 IND2=2
  2045. C                                                                       
  2046. C     OBSERVATION LOOP                                                  
  2047. C                                                                       
  2048.    16 CONTINUE
  2049.       IPR=0
  2050.       DO 23  I= I1, I2
  2051.       IPR= IPR+1
  2052.       IJ= I- J
  2053.       XI= X( I)
  2054.       YI= Y( I)
  2055.       ZI= Z( I)
  2056.       AI= BI( I)
  2057.       CABI= CAB( I)
  2058.       SABI= SAB( I)
  2059.       SALPI= SALP( I)
  2060.       CALL EFLD( XI, YI, ZI, AI, IJ)
  2061.       ETK= EXK* CABI+ EYK* SABI+ EZK* SALPI
  2062.       ETS= EXS* CABI+ EYS* SABI+ EZS* SALPI
  2063. C                                                                       
  2064. C     FILL MATRIX ELEMENTS.  ELEMENT LOCATIONS DETERMINED BY CONNECTION 
  2065. C     DATA.                                                             
  2066. C                                                                       
  2067.       ETC= EXC* CABI+ EYC* SABI+ EZC* SALPI
  2068. C     NORMAL FILL                                                       
  2069.       IF( ITRP.NE.0) GOTO 18
  2070.       DO 17  IJ=1, JSNO
  2071.       JX= JCO( IJ)
  2072.    17 CM( IPR, JX)= CM( IPR, JX)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX( 
  2073.      &IJ)
  2074.       GOTO 23
  2075. C     TRANSPOSED FILL                                                   
  2076.    18 IF( ITRP.EQ.2) GOTO 20
  2077.       DO 19  IJ=1, JSNO
  2078.       JX= JCO( IJ)
  2079.    19 CM( JX, IPR)= CM( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX( 
  2080.      &IJ)
  2081. C     TRANS. FILL FOR C(WW) - TEST FOR ELEMENTS FOR D(WW)PRIME.  (=CW)  
  2082.       GOTO 23
  2083.    20 DO 22  IJ=1, JSNO
  2084.       JX= JCO( IJ)
  2085.       IF( JX.GT. NR) GOTO 21
  2086.       CM( JX, IPR)= CM( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX( 
  2087.      &IJ)
  2088.       GOTO 22
  2089.    21 JX= JX- NR
  2090.       CW( JX, IPR)= CW( JX, IPR)+ ETK* AX( IJ)+ ETS* BX( IJ)+ ETC* CX( 
  2091.      &IJ)
  2092.    22 CONTINUE
  2093.    23 CONTINUE
  2094.       RETURN
  2095.       END
  2096. C ***
  2097. C     DOUBLE PRECISION 6/4/85
  2098. C
  2099.       SUBROUTINE CONECT( IGND)
  2100. C ***
  2101.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  2102. C                                                                       
  2103. C     CONNECT SETS UP SEGMENT CONNECTION DATA IN ARRAYS ICON1 AND ICON2 
  2104. C     BY SEARCHING FOR SEGMENT ENDS THAT ARE IN CONTACT.                
  2105. C                                                                       
  2106.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  2107.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  2108.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  2109.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  2110.       COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50), 
  2111.      &NSCON, IPCON(10), NPCON
  2112.       DIMENSION  X2(1), Y2(1), Z2(1)
  2113.       EQUIVALENCE(X2,SI),(Y2,ALP),(Z2,BET)
  2114.       DATA   JMAX/30/, SMIN/1.D-3/, NSMAX/50/, NPMAX/10/
  2115.       NSCON=0
  2116.       NPCON=0
  2117.       IF( IGND.EQ.0) GOTO 3
  2118.       WRITE( 6,54) 
  2119.       IF( IGND.GT.0) WRITE( 6,55) 
  2120.       IF( IPSYM.NE.2) GOTO 1
  2121.       NP=2* NP
  2122.       MP=2* MP
  2123.     1 IF( IABS( IPSYM).LE.2) GOTO 2
  2124.       NP= N
  2125.       MP= M
  2126.     2 IF( NP.GT. N) STOP
  2127.       IF( NP.EQ. N.AND. MP.EQ. M) IPSYM=0
  2128.     3 IF( N.EQ.0) GOTO 26
  2129.       DO 15  I=1, N
  2130.       ICONX( I)=0
  2131.       XI1= X( I)
  2132.       YI1= Y( I)
  2133.       ZI1= Z( I)
  2134.       XI2= X2( I)
  2135.       YI2= Y2( I)
  2136.       ZI2= Z2( I)
  2137. C                                                                       
  2138. C     DETERMINE CONNECTION DATA FOR END 1 OF SEGMENT.                   
  2139. C                                                                       
  2140.       SLEN= SQRT(( XI2- XI1)**2+( YI2- YI1)**2+( ZI2- ZI1)**2)* SMIN
  2141.       IF( IGND.LT.1) GOTO 5
  2142.       IF( ZI1.GT.- SLEN) GOTO 4
  2143.       WRITE( 6,56)  I
  2144.       STOP
  2145.     4 IF( ZI1.GT. SLEN) GOTO 5
  2146.       ICON1( I)= I
  2147.       Z( I)=0.
  2148.       GOTO 9
  2149.     5 IC= I
  2150.       DO 7  J=2, N
  2151.       IC= IC+1
  2152.       IF( IC.GT. N) IC=1
  2153.       SEP= ABS( XI1- X( IC))+ ABS( YI1- Y( IC))+ ABS( ZI1- Z( IC))
  2154.       IF( SEP.GT. SLEN) GOTO 6
  2155.       ICON1( I)=- IC
  2156.       GOTO 8
  2157.     6 SEP= ABS( XI1- X2( IC))+ ABS( YI1- Y2( IC))+ ABS( ZI1- Z2( IC))
  2158.       IF( SEP.GT. SLEN) GOTO 7
  2159.       ICON1( I)= IC
  2160.       GOTO 8
  2161.     7 CONTINUE
  2162.       IF( I.LT. N2.AND. ICON1( I).GT.10000) GOTO 8
  2163. C                                                                       
  2164. C     DETERMINE CONNECTION DATA FOR END 2 OF SEGMENT.                   
  2165. C                                                                       
  2166.       ICON1( I)=0
  2167.     8 IF( IGND.LT.1) GOTO 12
  2168.     9 IF( ZI2.GT.- SLEN) GOTO 10
  2169.       WRITE( 6,56)  I
  2170.       STOP
  2171.    10 IF( ZI2.GT. SLEN) GOTO 12
  2172.       IF( ICON1( I).NE. I) GOTO 11
  2173.       WRITE( 6,57)  I
  2174.       STOP
  2175.    11 ICON2( I)= I
  2176.       Z2( I)=0.
  2177.       GOTO 15
  2178.    12 IC= I
  2179.       DO 14  J=2, N
  2180.       IC= IC+1
  2181.       IF( IC.GT. N) IC=1
  2182.       SEP= ABS( XI2- X( IC))+ ABS( YI2- Y( IC))+ ABS( ZI2- Z( IC))
  2183.       IF( SEP.GT. SLEN) GOTO 13
  2184.       ICON2( I)= IC
  2185.       GOTO 15
  2186.    13 SEP= ABS( XI2- X2( IC))+ ABS( YI2- Y2( IC))+ ABS( ZI2- Z2( IC))
  2187.       IF( SEP.GT. SLEN) GOTO 14
  2188.       ICON2( I)=- IC
  2189.       GOTO 15
  2190.    14 CONTINUE
  2191.       IF( I.LT. N2.AND. ICON2( I).GT.10000) GOTO 15
  2192.       ICON2( I)=0
  2193.    15 CONTINUE
  2194. C     FIND WIRE-SURFACE CONNECTIONS FOR NEW PATCHES                     
  2195.       IF( M.EQ.0) GOTO 26
  2196.       IX= LD+1- M1
  2197.       I= M2
  2198.    16 IF( I.GT. M) GOTO 20
  2199.       IX= IX-1
  2200.       XS= X( IX)
  2201.       YS= Y( IX)
  2202.       ZS= Z( IX)
  2203.       DO 18  ISEG=1, N
  2204.       XI1= X( ISEG)
  2205.       YI1= Y( ISEG)
  2206.       ZI1= Z( ISEG)
  2207.       XI2= X2( ISEG)
  2208.       YI2= Y2( ISEG)
  2209.       ZI2= Z2( ISEG)
  2210. C     FOR FIRST END OF SEGMENT                                          
  2211.       SLEN=( ABS( XI2- XI1)+ ABS( YI2- YI1)+ ABS( ZI2- ZI1))* SMIN
  2212.       SEP= ABS( XI1- XS)+ ABS( YI1- YS)+ ABS( ZI1- ZS)
  2213. C     CONNECTION - DIVIDE PATCH INTO 4 PATCHES AT PRESENT ARRAY LOC.    
  2214.       IF( SEP.GT. SLEN) GOTO 17
  2215.       ICON1( ISEG)=10000+ I
  2216.       IC=0
  2217.       CALL SUBPH( I, IC, XI1, YI1, ZI1, XI2, YI2, ZI2, XA, YA, ZA, XS, 
  2218.      &YS, ZS)
  2219.       GOTO 19
  2220.    17 SEP= ABS( XI2- XS)+ ABS( YI2- YS)+ ABS( ZI2- ZS)
  2221.       IF( SEP.GT. SLEN) GOTO 18
  2222.       ICON2( ISEG)=10000+ I
  2223.       IC=0
  2224.       CALL SUBPH( I, IC, XI1, YI1, ZI1, XI2, YI2, ZI2, XA, YA, ZA, XS, 
  2225.      &YS, ZS)
  2226.       GOTO 19
  2227.    18 CONTINUE
  2228.    19 I= I+1
  2229. C     REPEAT SEARCH FOR NEW SEGMENTS CONNECTED TO NGF PATCHES.          
  2230.       GOTO 16
  2231.    20 IF( M1.EQ.0.OR. N2.GT. N) GOTO 26
  2232.       IX= LD+1
  2233.       I=1
  2234.    21 IF( I.GT. M1) GOTO 25
  2235.       IX= IX-1
  2236.       XS= X( IX)
  2237.       YS= Y( IX)
  2238.       ZS= Z( IX)
  2239.       DO 23  ISEG= N2, N
  2240.       XI1= X( ISEG)
  2241.       YI1= Y( ISEG)
  2242.       ZI1= Z( ISEG)
  2243.       XI2= X2( ISEG)
  2244.       YI2= Y2( ISEG)
  2245.       ZI2= Z2( ISEG)
  2246.       SLEN=( ABS( XI2- XI1)+ ABS( YI2- YI1)+ ABS( ZI2- ZI1))* SMIN
  2247.       SEP= ABS( XI1- XS)+ ABS( YI1- YS)+ ABS( ZI1- ZS)
  2248.       IF( SEP.GT. SLEN) GOTO 22
  2249.       ICON1( ISEG)=10001+ M
  2250.       IC=1
  2251.       NPCON= NPCON+1
  2252.       IPCON( NPCON)= I
  2253.       CALL SUBPH( I, IC, XI1, YI1, ZI1, XI2, YI2, ZI2, XA, YA, ZA, XS, 
  2254.      &YS, ZS)
  2255.       GOTO 24
  2256.    22 SEP= ABS( XI2- XS)+ ABS( YI2- YS)+ ABS( ZI2- ZS)
  2257.       IF( SEP.GT. SLEN) GOTO 23
  2258.       ICON2( ISEG)=10001+ M
  2259.       IC=1
  2260.       NPCON= NPCON+1
  2261.       IPCON( NPCON)= I
  2262.       CALL SUBPH( I, IC, XI1, YI1, ZI1, XI2, YI2, ZI2, XA, YA, ZA, XS, 
  2263.      &YS, ZS)
  2264.       GOTO 24
  2265.    23 CONTINUE
  2266.    24 I= I+1
  2267.       GOTO 21
  2268.    25 IF( NPCON.LE. NPMAX) GOTO 26
  2269.       WRITE( 6,62)  NPMAX
  2270.       STOP
  2271.    26 WRITE( 6,58)  N, NP, IPSYM
  2272.       IF( M.GT.0) WRITE( 6,61)  M, MP
  2273.       ISEG=( N+ M)/( NP+ MP)
  2274.       IF( ISEG.EQ.1) GOTO 30
  2275.       IF( IPSYM) 28,27,29
  2276.    27 STOP
  2277.    28 WRITE( 6,59)  ISEG
  2278.       GOTO 30
  2279.    29 IC= ISEG/2
  2280.       IF( ISEG.EQ.8) IC=3
  2281.       WRITE( 6,60)  IC
  2282.    30 IF( N.EQ.0) GOTO 48
  2283.       WRITE( 6,50) 
  2284. C     ADJUST CONNECTED SEG. ENDS TO EXACTLY COINCIDE.  PRINT JUNCTIONS  
  2285. C     OF 3 OR MORE SEG.  ALSO FIND OLD SEG. CONNECTING TO NEW SEG.      
  2286.       ISEG=0
  2287.       DO 44  J=1, N
  2288.       IEND=-1
  2289.       JEND=-1
  2290.       IX= ICON1( J)
  2291.       IC=1
  2292.       JCO(1)=- J
  2293.       XA= X( J)
  2294.       YA= Y( J)
  2295.       ZA= Z( J)
  2296.    31 IF( IX.EQ.0) GOTO 43
  2297.       IF( IX.EQ. J) GOTO 43
  2298.       IF( IX.GT.10000) GOTO 43
  2299.       NSFLG=0
  2300.    32 IF( IX) 33,49,34
  2301.    33 IX=- IX
  2302.       GOTO 35
  2303.    34 JEND=- JEND
  2304.    35 IF( IX.EQ. J) GOTO 37
  2305.       IF( IX.LT. J) GOTO 43
  2306.       IC= IC+1
  2307.       IF( IC.GT. JMAX) GOTO 49
  2308.       JCO( IC)= IX* JEND
  2309.       IF( IX.GT. N1) NSFLG=1
  2310.       IF( JEND.EQ.1) GOTO 36
  2311.       XA= XA+ X( IX)
  2312.       YA= YA+ Y( IX)
  2313.       ZA= ZA+ Z( IX)
  2314.       IX= ICON1( IX)
  2315.       GOTO 32
  2316.    36 XA= XA+ X2( IX)
  2317.       YA= YA+ Y2( IX)
  2318.       ZA= ZA+ Z2( IX)
  2319.       IX= ICON2( IX)
  2320.       GOTO 32
  2321.    37 SEP= IC
  2322.       XA= XA/ SEP
  2323.       YA= YA/ SEP
  2324.       ZA= ZA/ SEP
  2325.       DO 39  I=1, IC
  2326.       IX= JCO( I)
  2327.       IF( IX.GT.0) GOTO 38
  2328.       IX=- IX
  2329.       X( IX)= XA
  2330.       Y( IX)= YA
  2331.       Z( IX)= ZA
  2332.       GOTO 39
  2333.    38 X2( IX)= XA
  2334.       Y2( IX)= YA
  2335.       Z2( IX)= ZA
  2336.    39 CONTINUE
  2337.       IF( N1.EQ.0) GOTO 42
  2338.       IF( NSFLG.EQ.0) GOTO 42
  2339.       DO 41  I=1, IC
  2340.       IX= IABS( JCO( I))
  2341.       IF( IX.GT. N1) GOTO 41
  2342.       IF( ICONX( IX).NE.0) GOTO 41
  2343.       NSCON= NSCON+1
  2344.       IF( NSCON.LE. NSMAX) GOTO 40
  2345.       WRITE( 6,62)  NSMAX
  2346.       STOP
  2347.    40 ISCON( NSCON)= IX
  2348.       ICONX( IX)= NSCON
  2349.    41 CONTINUE
  2350.    42 IF( IC.LT.3) GOTO 43
  2351.       ISEG= ISEG+1
  2352.       WRITE( 6,51)  ISEG,( JCO( I), I=1, IC)
  2353.    43 IF( IEND.EQ.1) GOTO 44
  2354.       IEND=1
  2355.       JEND=1
  2356.       IX= ICON2( J)
  2357.       IC=1
  2358.       JCO(1)= J
  2359.       XA= X2( J)
  2360.       YA= Y2( J)
  2361.       ZA= Z2( J)
  2362.       GOTO 31
  2363.    44 CONTINUE
  2364.       IF( ISEG.EQ.0) WRITE( 6,52) 
  2365. C     FIND OLD SEGMENTS THAT CONNECT TO NEW PATCHES                     
  2366.       IF( N1.EQ.0.OR. M1.EQ. M) GOTO 48
  2367.       DO 47  J=1, N1
  2368.       IX= ICON1( J)
  2369.       IF( IX.LT.10000) GOTO 45
  2370.       IX= IX-10000
  2371.       IF( IX.GT. M1) GOTO 46
  2372.    45 IX= ICON2( J)
  2373.       IF( IX.LT.10000) GOTO 47
  2374.       IX= IX-10000
  2375.       IF( IX.LT. M2) GOTO 47
  2376.    46 IF( ICONX( J).NE.0) GOTO 47
  2377.       NSCON= NSCON+1
  2378.       ISCON( NSCON)= J
  2379.       ICONX( J)= NSCON
  2380.    47 CONTINUE
  2381.    48 CONTINUE
  2382.       RETURN
  2383.    49 WRITE( 6,53)  IX
  2384. C                                                                       
  2385.       STOP
  2386.    50 FORMAT(//,9X,'- MULTIPLE WIRE JUNCTIONS -',/,1X,'JUNCTION',4X,
  2387.      &'SEGMENTS  (- FOR END 1, + FOR END 2)')
  2388.    51 FORMAT(1X,I5,5X,20I5,/,(11X,20I5))
  2389.    52 FORMAT(2X,'NONE')
  2390.    53 FORMAT(' CONNECT - SEGMENT CONNECTION ERROR FOR SEGMENT',I5)
  2391.    54 FORMAT(/,3X,'GROUND PLANE SPECIFIED.')
  2392.    55 FORMAT(/,3X,'WHERE WIRE ENDS TOUCH GROUND, CURRENT WILL BE ',
  2393.      &'INTERPOLATED TO IMAGE IN GROUND PLANE.',/)
  2394.    56 FORMAT(' GEOMETRY DATA ERROR-- SEGMENT',I5,' EXTENDS BELOW GRO',
  2395.      &'UND')
  2396.    57 FORMAT(' GEOMETRY DATA ERROR--SEGMENT',I5,' LIES IN GROUND ',
  2397.      &'PLANE.')
  2398.    58 FORMAT(/,3X,'TOTAL SEGMENTS USED=',I5,5X,'NO. SEG. IN ','A SY',
  2399.      &'MMETRIC CELL=',I5,5X,'SYMMETRY FLAG=',I3)
  2400.    59 FORMAT(' STRUCTURE HAS',I4,' FOLD ROTATIONAL SYMMETRY',/)
  2401.    60 FORMAT(' STRUCTURE HAS',I2,' PLANES OF SYMMETRY',/)
  2402.    61 FORMAT(3X,'TOTAL PATCHES USED=',I5,6X,'NO. PATCHES IN A SYMMET',
  2403.      &'RIC CELL=',I5)
  2404.    62 FORMAT(' ERROR - NO. NEW SEGMENTS CONNECTED TO N.G.F. SEGMENTS',
  2405.      &'OR PATCHES EXCEEDS LIMIT OF',I5)
  2406.       END
  2407. C ***
  2408. C     DOUBLE PRECISION 6/4/85
  2409. C
  2410.       SUBROUTINE COUPLE( CUR, WLAM)
  2411. C ***
  2412.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  2413. C                                                                       
  2414. C     COUPLE COMPUTES THE MAXIMUM COUPLING BETWEEN PAIRS OF SEGMENTS.   
  2415. C                                                                       
  2416.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  2417.       COMPLEX  Y11A, Y12A, CUR, Y11, Y12, Y22, YL, YIN, ZL, ZIN, RHO
  2418.      &, VQD, VSANT, VQDS
  2419.       COMMON  /YPARM/ NCOUP, ICOUP, NCTAG(5), NCSEG(5), Y11A(5), Y12A(
  2420.      &20)
  2421.       COMMON  /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
  2422.      &, IQDS(30), NVQD, NSANT, NQDS
  2423.       DIMENSION  CUR(1)
  2424.       IF( NSANT.NE.1.OR. NVQD.NE.0) RETURN
  2425.       J= ISEGNO( NCTAG( ICOUP+1), NCSEG( ICOUP+1))
  2426.       IF( J.NE. ISANT(1)) RETURN
  2427.       ICOUP= ICOUP+1
  2428.       ZIN= VSANT(1)
  2429.       Y11A( ICOUP)= CUR( J)* WLAM/ ZIN
  2430.       L1=( ICOUP-1)*( NCOUP-1)
  2431.       DO 1  I=1, NCOUP
  2432.       IF( I.EQ. ICOUP) GOTO 1
  2433.       K= ISEGNO( NCTAG( I), NCSEG( I))
  2434.       L1= L1+1
  2435.       Y12A( L1)= CUR( K)* WLAM/ ZIN
  2436.     1 CONTINUE
  2437.       IF( ICOUP.LT. NCOUP) RETURN
  2438.       WRITE( 6,6) 
  2439.       NPM1= NCOUP-1
  2440.       DO 5  I=1, NPM1
  2441.       ITT1= NCTAG( I)
  2442.       ITS1= NCSEG( I)
  2443.       ISG1= ISEGNO( ITT1, ITS1)
  2444.       L1= I+1
  2445.       DO 5  J= L1, NCOUP
  2446.       ITT2= NCTAG( J)
  2447.       ITS2= NCSEG( J)
  2448.       ISG2= ISEGNO( ITT2, ITS2)
  2449.       J1= J+( I-1)* NPM1-1
  2450.       J2= I+( J-1)* NPM1
  2451.       Y11= Y11A( I)
  2452.       Y22= Y11A( J)
  2453.       Y12=.5*( Y12A( J1)+ Y12A( J2))
  2454.       YIN= Y12* Y12
  2455.       DBC= ABS( YIN)
  2456.       C= DBC/(2.* REAL( Y11)* REAL( Y22)- REAL( YIN))
  2457.       IF( C.LT.0..OR. C.GT.1.) GOTO 4
  2458.       IF( C.LT..01) GOTO 2
  2459.       GMAX=(1.- SQRT(1.- C* C))/ C
  2460.       GOTO 3
  2461.     2 GMAX=.5*( C+.25* C* C* C)
  2462.     3 RHO= GMAX* CONJG( YIN)/ DBC
  2463.       YL=((1.- RHO)/(1.+ RHO)+1.)* REAL( Y22)- Y22
  2464.       ZL=1./ YL
  2465.       YIN= Y11- YIN/( Y22+ YL)
  2466.       ZIN=1./ YIN
  2467.       DBC= DB10( GMAX)
  2468.       WRITE( 6,7)  ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, DBC, ZL, ZIN
  2469.       GOTO 5
  2470.     4 WRITE( 6,8)  ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, C
  2471.     5 CONTINUE
  2472. C                                                                       
  2473.       RETURN
  2474.     6 FORMAT(///,36X,'- - - ISOLATION DATA - - -',//,6X,'- - COUPLIN',
  2475.      &'G BETWEEN - -',8X,'MAXIMUM',15X,'- - - FOR MAXIMUM COUPLING - ',
  2476.      &'- -',/,12X,'SEG.',14X,'SEG.',3X,'COUPLING',4X,'LOAD IMPEDANCE ',
  2477.      &'(2ND SEG.)',7X,'INPUT IMPEDANCE',/,2X,'TAG/SEG.',3X,'NO.',4X,
  2478.      &'TAG/''SEG.',3X,'NO.',6X,'(DB)',8X,'REAL',9X,'IMAG.',9X,'REAL',9X
  2479.      &,'IMAG.')
  2480.     7 FORMAT(2(1X,I4,1X,I4,1X,I5,2X),F9.3,2X,1P,2(2X,E12.5,1X,E12.5))
  2481.     8 FORMAT(2(1X,I4,1X,I4,1X,I5,2X),'**ERROR** COUPLING IS NOT BETWE',
  2482.      &'EN 0 AND 1. (=',1P,E12.5,')')
  2483.       END
  2484. C ***
  2485. C     DOUBLE PRECISION 6/4/85
  2486. C
  2487.       SUBROUTINE DATAGN
  2488. C ***
  2489.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  2490. C                                                                       
  2491. C     DATAGN IS THE MAIN ROUTINE FOR INPUT OF GEOMETRY DATA.            
  2492. C                                                                       
  2493. C***
  2494.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  2495. C***
  2496.       CHARACTER *2  GM, ATST
  2497. C***
  2498.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  2499.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  2500.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  2501.       COMMON  /ANGL/ SALP( NM)
  2502. C***
  2503.       COMMON  /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
  2504.       DIMENSION  X2(1), Y2(1), Z2(1), T1X(1), T1Y(1), T1Z(1), T2X(1), 
  2505.      &T2Y(1), T2Z(1), ATST(13), IFX(2), IFY(2), IFZ(2), CAB(1), SAB(1),
  2506.      & IPT(4)
  2507. C***
  2508.       EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
  2509.      &T2Z,ITAG),(X2,SI),(Y2,ALP),(Z2,BET),(CAB,ALP),(SAB,BET)
  2510. C***
  2511.       data atst/'GW','GX','GR','GS','GE','GM','SP','SM','GF','GA',
  2512.      $          'SC','GC','GH'/
  2513. *      DATA   ATST/2HGW,2HGX,2HGR,2HGS,2HGE,2HGM,2HSP,2HSM,2HGF,2HGA,
  2514. *     &2HSC,2HGC,2HGH/
  2515.       DATA   IFX/1H ,1HX/, IFY/1H ,1HY/, IFZ/1H ,1HZ/
  2516.       DATA   TA/0.01745329252D+0/, TD/57.29577951D+0/, IPT/1HP,1HR,1HT,
  2517.      &1HQ/
  2518.       IPSYM=0
  2519.       NWIRE=0
  2520.       N=0
  2521.       NP=0
  2522.       M=0
  2523.       MP=0
  2524.       N1=0
  2525.       N2=1
  2526.       M1=0
  2527.       M2=1
  2528.       ISCT=0
  2529. C                                                                       
  2530. C     READ GEOMETRY DATA CARD AND BRANCH TO SECTION FOR OPERATION       
  2531. C     REQUESTED                                                         
  2532. C                                                                       
  2533. C***   
  2534. C 1     READ (5,42) GM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD                
  2535.       IPHD=0
  2536. C***
  2537.     1 CALL READGM( GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD)
  2538.       IF( N+ M.GT. LD) GOTO 37
  2539.       IF( GM.EQ. ATST(9)) GOTO 27
  2540.       IF( IPHD.EQ.1) GOTO 2
  2541.       WRITE( 6,40) 
  2542.       WRITE( 6,41) 
  2543.       IPHD=1
  2544.     2 IF( GM.EQ. ATST(11)) GOTO 10
  2545.       ISCT=0
  2546.       IF( GM.EQ. ATST(1)) GOTO 3
  2547.       IF( GM.EQ. ATST(2)) GOTO 18
  2548.       IF( GM.EQ. ATST(3)) GOTO 19
  2549.       IF( GM.EQ. ATST(4)) GOTO 21
  2550.       IF( GM.EQ. ATST(7)) GOTO 9
  2551.       IF( GM.EQ. ATST(8)) GOTO 13
  2552.       IF( GM.EQ. ATST(5)) GOTO 29
  2553.       IF( GM.EQ. ATST(6)) GOTO 26
  2554. C***
  2555.       IF( GM.EQ. ATST(10)) GOTO 8
  2556. C***
  2557.       IF( GM.EQ. ATST(13)) GOTO 123
  2558. C                                                                       
  2559. C     GENERATE SEGMENT DATA FOR STRAIGHT WIRE.                          
  2560. C                                                                       
  2561.       GOTO 36
  2562.     3 NWIRE= NWIRE+1
  2563.       I1= N+1
  2564.       I2= N+ NS
  2565.       WRITE( 6,43)  NWIRE, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, NS, I1, 
  2566.      &I2, ITG
  2567.       IF( RAD.EQ.0) GOTO 4
  2568.       XS1=1.
  2569.       YS1=1.
  2570. C***
  2571.       GOTO 7
  2572. C 4     READ (5,42) GM,IX,IY,XS1,YS1,ZS1                                 
  2573. C***
  2574.     4 CALL READGM( GM, IX, IY, XS1, YS1, ZS1, DUMMY, DUMMY, DUMMY, 
  2575.      &DUMMY)
  2576.       IF( GM.EQ. ATST(12)) GOTO 6
  2577.     5 WRITE( 6,48) 
  2578.       STOP
  2579.     6 WRITE( 6,61)  XS1, YS1, ZS1
  2580.       IF( YS1.EQ.0.OR. ZS1.EQ.0) GOTO 5
  2581.       RAD= YS1
  2582.       YS1=( ZS1/ YS1)**(1./( NS-1.))
  2583.     7 CALL WIRE( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, XS1, YS1, NS, ITG)
  2584. C                                                                       
  2585. C     GENERATE SEGMENT DATA FOR WIRE ARC                                
  2586. C                                                                       
  2587.       GOTO 1
  2588.     8 NWIRE= NWIRE+1
  2589.       I1= N+1
  2590.       I2= N+ NS
  2591.       WRITE( 6,38)  NWIRE, XW1, YW1, ZW1, XW2, NS, I1, I2, ITG
  2592.       CALL ARC( ITG, NS, XW1, YW1, ZW1, XW2)
  2593. C***
  2594. C
  2595. C     GENERATE HELIX
  2596. C
  2597.       GOTO 1
  2598.   123 NWIRE= NWIRE+1
  2599.       I1= N+1
  2600.       I2= N+ NS
  2601.       WRITE( 6,124)  XW1, YW1, NWIRE, ZW1, XW2, YW2, ZW2, RAD, NS, I1, 
  2602.      &I2, ITG
  2603.       CALL HELIX( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, NS, ITG)
  2604. C
  2605.       GOTO 1
  2606. C***
  2607. C                                                                       
  2608. C     GENERATE SINGLE NEW PATCH                                         
  2609. C                                                                       
  2610.   124 FORMAT(5X,'HELIX STRUCTURE-   AXIAL SPACING BETWEEN TURNS =',F8.3
  2611.      &,' TOTAL AXIAL LENGTH =',F8.3/1X,I5,2X,'RADIUS OF HELIX =',4(2X,F
  2612.      &8.3),7X,F11.5,I8,4X,I5,1X,I5,3X,I5)
  2613.     9 I1= M+1
  2614.       NS= NS+1
  2615.       IF( ITG.NE.0) GOTO 17
  2616.       WRITE( 6,51)  I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2
  2617.       IF( NS.EQ.2.OR. NS.EQ.4) ISCT=1
  2618.       IF( NS.GT.1) GOTO 14
  2619.       XW2= XW2* TA
  2620.       YW2= YW2* TA
  2621.       GOTO 16
  2622.    10 IF( ISCT.EQ.0) GOTO 17
  2623.       I1= M+1
  2624.       NS= NS+1
  2625.       IF( ITG.NE.0) GOTO 17
  2626.       IF( NS.NE.2.AND. NS.NE.4) GOTO 17
  2627.       XS1= X4
  2628.       YS1= Y4
  2629.       ZS1= Z4
  2630.       XS2= X3
  2631.       YS2= Y3
  2632.       ZS2= Z3
  2633.       X3= XW1
  2634.       Y3= YW1
  2635.       Z3= ZW1
  2636.       IF( NS.NE.4) GOTO 11
  2637.       X4= XW2
  2638.       Y4= YW2
  2639.       Z4= ZW2
  2640.    11 XW1= XS1
  2641.       YW1= YS1
  2642.       ZW1= ZS1
  2643.       XW2= XS2
  2644.       YW2= YS2
  2645.       ZW2= ZS2
  2646.       IF( NS.EQ.4) GOTO 12
  2647.       X4= XW1+ X3- XW2
  2648.       Y4= YW1+ Y3- YW2
  2649.       Z4= ZW1+ Z3- ZW2
  2650.    12 WRITE( 6,51)  I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2
  2651.       WRITE( 6,39)  X3, Y3, Z3, X4, Y4, Z4
  2652. C                                                                       
  2653. C     GENERATE MULTIPLE-PATCH SURFACE                                   
  2654. C                                                                       
  2655.       GOTO 16
  2656.    13 I1= M+1
  2657.       WRITE( 6,59)  I1, IPT(2), XW1, YW1, ZW1, XW2, YW2, ZW2, ITG, NS
  2658. C***
  2659.       IF( ITG.LT.1.OR. NS.LT.1) GOTO 17
  2660. C 14    READ (5,42) GM,IX,IY,X3,Y3,Z3,X4,Y4,Z4                           
  2661. C***
  2662.    14 CALL READGM( GM, IX, IY, X3, Y3, Z3, X4, Y4, Z4, DUMMY)
  2663.       IF( NS.NE.2.AND. ITG.LT.1) GOTO 15
  2664.       X4= XW1+ X3- XW2
  2665.       Y4= YW1+ Y3- YW2
  2666.       Z4= ZW1+ Z3- ZW2
  2667.    15 WRITE( 6,39)  X3, Y3, Z3, X4, Y4, Z4
  2668.       IF( GM.NE. ATST(11)) GOTO 17
  2669.    16 CALL PATCH( ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, X3, Y3, Z3, X4
  2670.      &, Y4, Z4)
  2671.       GOTO 1
  2672.    17 WRITE( 6,60) 
  2673. C                                                                       
  2674. C     REFLECT STRUCTURE ALONG X,Y, OR Z AXES OR ROTATE TO FORM CYLINDER.
  2675. C                                                                       
  2676.       STOP
  2677.    18 IY= NS/10
  2678.       IZ= NS- IY*10
  2679.       IX= IY/10
  2680.       IY= IY- IX*10
  2681.       IF( IX.NE.0) IX=1
  2682.       IF( IY.NE.0) IY=1
  2683.       IF( IZ.NE.0) IZ=1
  2684.       WRITE( 6,44)  IFX( IX+1), IFY( IY+1), IFZ( IZ+1), ITG
  2685.       GOTO 20
  2686.    19 WRITE( 6,45)  NS, ITG
  2687.       IX=-1
  2688.    20 CALL REFLC( IX, IY, IZ, ITG, NS)
  2689. C                                                                       
  2690. C     SCALE STRUCTURE DIMENSIONS BY FACTOR XW1.                         
  2691. C                                                                       
  2692.       GOTO 1
  2693.    21 IF( N.LT. N2) GOTO 23
  2694.       DO 22  I= N2, N
  2695.       X( I)= X( I)* XW1
  2696.       Y( I)= Y( I)* XW1
  2697.       Z( I)= Z( I)* XW1
  2698.       X2( I)= X2( I)* XW1
  2699.       Y2( I)= Y2( I)* XW1
  2700.       Z2( I)= Z2( I)* XW1
  2701.    22 BI( I)= BI( I)* XW1
  2702.    23 IF( M.LT. M2) GOTO 25
  2703.       YW1= XW1* XW1
  2704.       IX= LD+1- M
  2705.       IY= LD- M1
  2706.       DO 24  I= IX, IY
  2707.       X( I)= X( I)* XW1
  2708.       Y( I)= Y( I)* XW1
  2709.       Z( I)= Z( I)* XW1
  2710.    24 BI( I)= BI( I)* YW1
  2711.    25 WRITE( 6,46)  XW1
  2712. C                                                                       
  2713. C     MOVE STRUCTURE OR REPRODUCE ORIGINAL STRUCTURE IN NEW POSITIONS.  
  2714. C                                                                       
  2715.       GOTO 1
  2716.    26 WRITE( 6,47)  ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD
  2717.       XW1= XW1* TA
  2718.       YW1= YW1* TA
  2719.       ZW1= ZW1* TA
  2720.       CALL MOVE( XW1, YW1, ZW1, XW2, YW2, ZW2, INT( RAD+.5), NS, ITG)
  2721. C                                                                       
  2722. C     READ NUMERICAL GREEN'S FUNCTION TAPE                              
  2723. C                                                                       
  2724.       GOTO 1
  2725.    27 IF( N+ M.EQ.0) GOTO 28
  2726.       WRITE( 6,52) 
  2727.       STOP
  2728.    28 CALL GFIL( ITG)
  2729.       NPSAV= NP
  2730.       MPSAV= MP
  2731.       IPSAV= IPSYM
  2732. C                                                                       
  2733. C     TERMINATE STRUCTURE GEOMETRY INPUT.                               
  2734. C                                                                       
  2735. C***
  2736.       GOTO 1
  2737.    29 IF( NS.EQ.0) GOTO 290
  2738.       IPLP1=1
  2739.       IPLP2=1
  2740. C***
  2741.   290 IX= N1+ M1
  2742.       IF( IX.EQ.0) GOTO 30
  2743.       NP= N
  2744.       MP= M
  2745.       IPSYM=0
  2746.    30 CALL CONECT( ITG)
  2747.       IF( IX.EQ.0) GOTO 31
  2748.       NP= NPSAV
  2749.       MP= MPSAV
  2750.       IPSYM= IPSAV
  2751.    31 IF( N+ M.GT. LD) GOTO 37
  2752.       IF( N.EQ.0) GOTO 33
  2753.       WRITE( 6,53) 
  2754.       WRITE( 6,54) 
  2755.       DO 32  I=1, N
  2756.       XW1= X2( I)- X( I)
  2757.       YW1= Y2( I)- Y( I)
  2758.       ZW1= Z2( I)- Z( I)
  2759.       X( I)=( X( I)+ X2( I))*.5
  2760.       Y( I)=( Y( I)+ Y2( I))*.5
  2761.       Z( I)=( Z( I)+ Z2( I))*.5
  2762.       XW2= XW1* XW1+ YW1* YW1+ ZW1* ZW1
  2763.       YW2= SQRT( XW2)
  2764.       YW2=( XW2/ YW2+ YW2)*.5
  2765.       SI( I)= YW2
  2766.       CAB( I)= XW1/ YW2
  2767.       SAB( I)= YW1/ YW2
  2768.       XW2= ZW1/ YW2
  2769.       IF( XW2.GT.1.) XW2=1.
  2770.       IF( XW2.LT.-1.) XW2=-1.
  2771.       SALP( I)= XW2
  2772.       XW2= ASIN( XW2)* TD
  2773.       YW2= ATGN2( YW1, XW1)* TD
  2774. C***
  2775.       WRITE( 6,55)  I, X( I), Y( I), Z( I), SI( I), XW2, YW2, BI( I), 
  2776.      &ICON1( I), I, ICON2( I), ITAG( I)
  2777.       IF( IPLP1.NE.1) GOTO 320
  2778.       WRITE( 8,*)  X( I), Y( I), Z( I), SI( I), XW2, YW2, BI( I), ICON1
  2779.      &( I), I, ICON2( I)
  2780. C***
  2781.   320 CONTINUE
  2782.       IF( SI( I).GT.1.D-20.AND. BI( I).GT.0.) GOTO 32
  2783.       WRITE( 6,56) 
  2784.       STOP
  2785.    32 CONTINUE
  2786.    33 IF( M.EQ.0) GOTO 35
  2787.       WRITE( 6,57) 
  2788.       J= LD+1
  2789.       DO 34  I=1, M
  2790.       J= J-1
  2791.       XW1=( T1Y( J)* T2Z( J)- T1Z( J)* T2Y( J))* SALP( J)
  2792.       YW1=( T1Z( J)* T2X( J)- T1X( J)* T2Z( J))* SALP( J)
  2793.       ZW1=( T1X( J)* T2Y( J)- T1Y( J)* T2X( J))* SALP( J)
  2794.       WRITE( 6,58)  I, X( J), Y( J), Z( J), XW1, YW1, ZW1, BI( J), T1X(
  2795.      & J), T1Y( J), T1Z( J), T2X( J), T2Y( J), T2Z( J)
  2796.    34 CONTINUE
  2797.    35 RETURN
  2798.    36 WRITE( 6,48) 
  2799.       WRITE( 6,49)  GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD
  2800.       STOP
  2801.    37 WRITE( 6,50) 
  2802. C                                                                       
  2803.       STOP
  2804.    38 FORMAT(1X,I5,2X,'ARC RADIUS =',F9.5,2X,'FROM',F8.3,' TO',F8.3,
  2805.      &' DEGREES',11X,F11.5,2X,I5,4X,I5,1X,I5,3X,I5)
  2806.    39 FORMAT(6X,3F11.5,1X,3F11.5)
  2807.    40 FORMAT(////,33X,'- - - STRUCTURE SPECIFICATION - - -',//,37X,
  2808.      &'COORDINATES MUST BE INPUT IN',/,37X,
  2809.      &'METERS OR BE SCALED TO METERS',/,37X,
  2810.      &'BEFORE STRUCTURE INPUT IS ENDED',//)
  2811.    41 FORMAT(2X,'WIRE',79X,'NO. OF',4X,'FIRST',2X,'LAST',5X,'TAG',/,2X,
  2812.      &'NO.',8X,'X1',9X,'Y1',9X,'Z1',10X,'X2',9X,'Y2',9X,'Z2',6X,
  2813.      &'RADIUS',3X,'SEG.',5X,'SEG.',3X,'SEG.',5X,'NO.')
  2814.    42 FORMAT(A2, I3, I5, 7F10.5)
  2815.    43 FORMAT(1X,I5,3F11.5,1X,4F11.5,2X,I5,4X,I5,1X,I5,3X,I5)
  2816.    44 FORMAT(6X,'STRUCTURE REFLECTED ALONG THE AXES',3(1X,A1),'.  TA',
  2817.      &'GS INCREMENTED BY',I5)
  2818.    45 FORMAT(6X,'STRUCTURE ROTATED ABOUT Z-AXIS',I3,' TIMES.  LABELS',
  2819.      &' INCREMENTED BY',I5)
  2820.    46 FORMAT(6X,'STRUCTURE SCALED BY FACTOR',F10.5)
  2821.    47 FORMAT(6X,'THE STRUCTURE HAS BEEN MOVED, MOVE DATA CARD IS -/6X',
  2822.      &I3,I5,7F10.5)
  2823.    48 FORMAT(' GEOMETRY DATA CARD ERROR')
  2824.    49 FORMAT(1X,A2,I3,I5,7F10.5)
  2825.    50 FORMAT(' NUMBER OF WIRE SEGMENTS AND SURFACE PATCHES EXCEEDS DI',
  2826.      &'MENSION LIMIT.')
  2827.    51 FORMAT(1X,I5,A1,F10.5,2F11.5,1X,3F11.5)
  2828.    52 FORMAT(' ERROR - GF MUST BE FIRST GEOMETRY DATA CARD')
  2829.    53 FORMAT(////33X,'- - - - SEGMENTATION DATA - - - -',//,40X,'COO',
  2830.      &'RDINATES IN METERS',//,25X,
  2831.      &'I+ AND I- INDICATE THE SEGMENTS BEFORE AND AFTER I',//)
  2832.    54 FORMAT(2X,'SEG.',3X,'COORDINATES OF SEG. CENTER',5X,'SEG.',5X,
  2833.      &'ORIENTATION ANGLES',4X,'WIRE',4X,'CONNECTION DATA',3X,'TAG',/,2X
  2834.      &,'NO.',7X,'X',9X,'Y',9X,'Z',7X,'LENGTH',5X,'ALPHA',5X,'BETA',6X,
  2835.      &'RADIUS',4X,'I-',3X,'I',4X,'I+',4X,'NO.')
  2836.    55 FORMAT(1X,I5,4F10.5,1X,3F10.5,1X,3I5,2X,I5)
  2837.    56 FORMAT(' SEGMENT DATA ERROR')
  2838.    57 FORMAT(////,44X,'- - - SURFACE PATCH DATA - - -',//,49X,'COORD',
  2839.      &'INATES IN METERS',//,1X,'PATCH',5X,'COORD. OF PATCH CENTER',7X,
  2840.      &'UNIT NORMAL VECTOR',6X,'PATCH',12X,
  2841.      &'COMPONENTS OF UNIT TANGENT V''ECTORS',/,2X,'NO.',6X,'X',9X,'Y',9
  2842.      &X,'Z',9X,'X',7X,'Y',7X,'Z',7X,'AREA',7X,'X1',6X,'Y1',6X,'Z1',7X,
  2843.      &'X2',6X,'Y2',6X,'Z2')
  2844.    58 FORMAT(1X,I4,3F10.5,1X,3F8.4,F10.5,1X,3F8.4,1X,3F8.4)
  2845.    59 FORMAT(1X,I5,A1,F10.5,2F11.5,1X,3F11.5,5X,'SURFACE -',I4,' BY',I3
  2846.      &,' PATCHES')
  2847.    60 FORMAT(' PATCH DATA ERROR')
  2848.    61 FORMAT(9X,'ABOVE WIRE IS TAPERED.  SEG. LENGTH RATIO =',F9.5,/,33
  2849.      &X,'RADIUS FROM',F9.5,' TO',F9.5)
  2850.       END
  2851. C ***
  2852. C     DOUBLE PRECISION 6/4/85
  2853. C
  2854.       FUNCTION DB10( X)
  2855. C ***
  2856. C                                                                       
  2857. C     FUNCTION DB-- RETURNS DB FOR MAGNITUDE (FIELD) OR MAG**2 (POWER) I
  2858. C                                                                       
  2859.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  2860.       F=10.
  2861.       GOTO 1
  2862.       ENTRY DB20 (x)
  2863.       F=20.
  2864.     1 IF( X.LT.1.D-20) GOTO 2
  2865.       DB10= F* LOG10( X)
  2866.       RETURN
  2867.     2 DB10=-999.99
  2868.       RETURN
  2869.       END
  2870. C ***
  2871. C     DOUBLE PRECISION 6/4/85
  2872. C
  2873.       SUBROUTINE EFLD( XI, YI, ZI, AI, IJ)
  2874. C ***
  2875.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  2876. C                                                                       
  2877. C     COMPUTE NEAR E FIELDS OF A SEGMENT WITH SINE, COSINE, AND         
  2878. C     CONSTANT CURRENTS.  GROUND EFFECT INCLUDED.                       
  2879. C                                                                       
  2880.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  2881.       COMPLEX  TXK, TYK, TZK, TXS, TYS, TZS, TXC, TYC, TZC, EXK, EYK
  2882.      &, EZK, EXS, EYS, EZS, EXC, EYC, EZC, EPX, EPY, ZRATI, REFS, REFPS
  2883.      &, ZRSIN, ZRATX, T1, ZSCRN, ZRATI2, TEZS, TERS, TEZC, TERC, TEZK, 
  2884.      &TERK, EGND, FRATI
  2885.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  2886.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  2887.      &INDD2, IPGND
  2888.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  2889.      &KSYMP, IFAR, IPERF, T1, T2
  2890.       COMMON  /INCOM/ XO, YO, ZO, SN, XSN, YSN, ISNOR
  2891.       DIMENSION  EGND(9)
  2892.       EQUIVALENCE(EGND(1),TXK),(EGND(2),TYK),(EGND(3),TZK),(EGND(4),TXS
  2893.      &),(EGND(5),TYS),(EGND(6),TZS),(EGND(7),TXC),(EGND(8),TYC),(EGND(9
  2894.      &),TZC)
  2895.       DATA   ETA/376.73/, PI/3.141592654D+0/, TP/6.283185308D+0/
  2896.       XIJ= XI- XJ
  2897.       YIJ= YI- YJ
  2898.       IJX= IJ
  2899.       RFL=-1.
  2900.       DO 12  IP=1, KSYMP
  2901.       IF( IP.EQ.2) IJX=1
  2902.       RFL=- RFL
  2903.       SALPR= SALPJ* RFL
  2904.       ZIJ= ZI- RFL* ZJ
  2905.       ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR
  2906.       RHOX= XIJ- CABJ* ZP
  2907.       RHOY= YIJ- SABJ* ZP
  2908.       RHOZ= ZIJ- SALPR* ZP
  2909.       RH= SQRT( RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ+ AI* AI)
  2910.       IF( RH.GT.1.D-10) GOTO 1
  2911.       RHOX=0.
  2912.       RHOY=0.
  2913.       RHOZ=0.
  2914.       GOTO 2
  2915.     1 RHOX= RHOX/ RH
  2916.       RHOY= RHOY/ RH
  2917.       RHOZ= RHOZ/ RH
  2918.     2 R= SQRT( ZP* ZP+ RH* RH)
  2919. C                                                                       
  2920. C     LUMPED CURRENT ELEMENT APPROX. FOR LARGE SEPARATIONS              
  2921. C                                                                       
  2922.       IF( R.LT. RKH) GOTO 3
  2923.       RMAG= TP* R
  2924.       CTH= ZP/ R
  2925.       PX= RH/ R
  2926.       TXK= CMPLX( COS( RMAG),- SIN( RMAG))
  2927.       PY= TP* R* R
  2928.       TYK= ETA* CTH* TXK* CMPLX(1.D+0,-1.D+0/ RMAG)/ PY
  2929.       TZK= ETA* PX* TXK* CMPLX(1.D+0, RMAG-1.D+0/ RMAG)/(2.* PY)
  2930.       TEZK= TYK* CTH- TZK* PX
  2931.       TERK= TYK* PX+ TZK* CTH
  2932.       RMAG= SIN( PI* S)/ PI
  2933.       TEZC= TEZK* RMAG
  2934.       TERC= TERK* RMAG
  2935.       TEZK= TEZK* S
  2936.       TERK= TERK* S
  2937.       TXS=(0.,0.)
  2938.       TYS=(0.,0.)
  2939.       TZS=(0.,0.)
  2940.       GOTO 6
  2941. C                                                                       
  2942. C     EKSC FOR THIN WIRE APPROX. OR EKSCX FOR EXTENDED T.W. APPROX.     
  2943. C                                                                       
  2944.     3 IF( IEXK.EQ.1) GOTO 4
  2945.       CALL EKSC( S, ZP, RH, TP, IJX, TEZS, TERS, TEZC, TERC, TEZK, TERK
  2946.      &)
  2947.       GOTO 5
  2948.     4 CALL EKSCX( B, S, ZP, RH, TP, IJX, IND1, IND2, TEZS, TERS, TEZC, 
  2949.      &TERC, TEZK, TERK)
  2950.     5 TXS= TEZS* CABJ+ TERS* RHOX
  2951.       TYS= TEZS* SABJ+ TERS* RHOY
  2952.       TZS= TEZS* SALPR+ TERS* RHOZ
  2953.     6 TXK= TEZK* CABJ+ TERK* RHOX
  2954.       TYK= TEZK* SABJ+ TERK* RHOY
  2955.       TZK= TEZK* SALPR+ TERK* RHOZ
  2956.       TXC= TEZC* CABJ+ TERC* RHOX
  2957.       TYC= TEZC* SABJ+ TERC* RHOY
  2958.       TZC= TEZC* SALPR+ TERC* RHOZ
  2959.       IF( IP.NE.2) GOTO 11
  2960.       IF( IPERF.GT.0) GOTO 10
  2961.       ZRATX= ZRATI
  2962.       RMAG= R
  2963. C                                                                       
  2964. C     SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.                     
  2965. C                                                                       
  2966.       XYMAG= SQRT( XIJ* XIJ+ YIJ* YIJ)
  2967.       IF( NRADL.EQ.0) GOTO 7
  2968.       XSPEC=( XI* ZJ+ ZI* XJ)/( ZI+ ZJ)
  2969.       YSPEC=( YI* ZJ+ ZI* YJ)/( ZI+ ZJ)
  2970.       RHOSPC= SQRT( XSPEC* XSPEC+ YSPEC* YSPEC+ T2* T2)
  2971.       IF( RHOSPC.GT. SCRWL) GOTO 7
  2972.       ZSCRN= T1* RHOSPC* LOG( RHOSPC/ T2)
  2973.       ZRATX=( ZSCRN* ZRATI)/( ETA* ZRATI+ ZSCRN)
  2974. C                                                                       
  2975. C     CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.  
  2976. C                                                                       
  2977.     7 IF( XYMAG.GT.1.D-6) GOTO 8
  2978.       PX=0.
  2979.       PY=0.
  2980.       CTH=1.
  2981.       ZRSIN=(1.,0.)
  2982.       GOTO 9
  2983.     8 PX=- YIJ/ XYMAG
  2984.       PY= XIJ/ XYMAG
  2985.       CTH= ZIJ/ RMAG
  2986.       ZRSIN= SQRT(1.- ZRATX* ZRATX*(1.- CTH* CTH))
  2987.     9 REFS=( CTH- ZRATX* ZRSIN)/( CTH+ ZRATX* ZRSIN)
  2988.       REFPS=-( ZRATX* CTH- ZRSIN)/( ZRATX* CTH+ ZRSIN)
  2989.       REFPS= REFPS- REFS
  2990.       EPY= PX* TXK+ PY* TYK
  2991.       EPX= PX* EPY
  2992.       EPY= PY* EPY
  2993.       TXK= REFS* TXK+ REFPS* EPX
  2994.       TYK= REFS* TYK+ REFPS* EPY
  2995.       TZK= REFS* TZK
  2996.       EPY= PX* TXS+ PY* TYS
  2997.       EPX= PX* EPY
  2998.       EPY= PY* EPY
  2999.       TXS= REFS* TXS+ REFPS* EPX
  3000.       TYS= REFS* TYS+ REFPS* EPY
  3001.       TZS= REFS* TZS
  3002.       EPY= PX* TXC+ PY* TYC
  3003.       EPX= PX* EPY
  3004.       EPY= PY* EPY
  3005.       TXC= REFS* TXC+ REFPS* EPX
  3006.       TYC= REFS* TYC+ REFPS* EPY
  3007.       TZC= REFS* TZC
  3008.    10 EXK= EXK- TXK* FRATI
  3009.       EYK= EYK- TYK* FRATI
  3010.       EZK= EZK- TZK* FRATI
  3011.       EXS= EXS- TXS* FRATI
  3012.       EYS= EYS- TYS* FRATI
  3013.       EZS= EZS- TZS* FRATI
  3014.       EXC= EXC- TXC* FRATI
  3015.       EYC= EYC- TYC* FRATI
  3016.       EZC= EZC- TZC* FRATI
  3017.       GOTO 12
  3018.    11 EXK= TXK
  3019.       EYK= TYK
  3020.       EZK= TZK
  3021.       EXS= TXS
  3022.       EYS= TYS
  3023.       EZS= TZS
  3024.       EXC= TXC
  3025.       EYC= TYC
  3026.       EZC= TZC
  3027.    12 CONTINUE
  3028.       IF( IPERF.EQ.2) GOTO 13
  3029. C                                                                       
  3030. C     FIELD DUE TO GROUND USING SOMMERFELD/NORTON                       
  3031. C                                                                       
  3032.       RETURN
  3033.    13 SN= SQRT( CABJ* CABJ+ SABJ* SABJ)
  3034.       IF( SN.LT.1.D-5) GOTO 14
  3035.       XSN= CABJ/ SN
  3036.       YSN= SABJ/ SN
  3037.       GOTO 15
  3038.    14 SN=0.
  3039.       XSN=1.
  3040. C                                                                       
  3041. C     DISPLACE OBSERVATION POINT FOR THIN WIRE APPROXIMATION            
  3042. C                                                                       
  3043.       YSN=0.
  3044.    15 ZIJ= ZI+ ZJ
  3045.       SALPR=- SALPJ
  3046.       RHOX= SABJ* ZIJ- SALPR* YIJ
  3047.       RHOY= SALPR* XIJ- CABJ* ZIJ
  3048.       RHOZ= CABJ* YIJ- SABJ* XIJ
  3049.       RH= RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ
  3050.       IF( RH.GT.1.D-10) GOTO 16
  3051.       XO= XI- AI* YSN
  3052.       YO= YI+ AI* XSN
  3053.       ZO= ZI
  3054.       GOTO 17
  3055.    16 RH= AI/ SQRT( RH)
  3056.       IF( RHOZ.LT.0.) RH=- RH
  3057.       XO= XI+ RH* RHOX
  3058.       YO= YI+ RH* RHOY
  3059.       ZO= ZI+ RH* RHOZ
  3060.    17 R= XIJ* XIJ+ YIJ* YIJ+ ZIJ* ZIJ
  3061. C                                                                       
  3062. C     FIELD FROM INTERPOLATION IS INTEGRATED OVER SEGMENT               
  3063. C                                                                       
  3064.       IF( R.GT..95) GOTO 18
  3065.       ISNOR=1
  3066.       DMIN= EXK* CONJG( EXK)+ EYK* CONJG( EYK)+ EZK* CONJG( EZK)
  3067.       DMIN=.01* SQRT( DMIN)
  3068.       SHAF=.5* S
  3069.       CALL ROM2(- SHAF, SHAF, EGND, DMIN)
  3070. C                                                                       
  3071. C     NORTON FIELD EQUATIONS AND LUMPED CURRENT ELEMENT APPROXIMATION   
  3072. C                                                                       
  3073.       GOTO 19
  3074.    18 ISNOR=2
  3075.       CALL SFLDS(0., EGND)
  3076.       GOTO 22
  3077.    19 ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR
  3078.       RH= R- ZP* ZP
  3079.       IF( RH.GT.1.D-10) GOTO 20
  3080.       DMIN=0.
  3081.       GOTO 21
  3082.    20 DMIN= SQRT( RH/( RH+ AI* AI))
  3083.    21 IF( DMIN.GT..95) GOTO 22
  3084.       PX=1.- DMIN
  3085.       TERK=( TXK* CABJ+ TYK* SABJ+ TZK* SALPR)* PX
  3086.       TXK= DMIN* TXK+ TERK* CABJ
  3087.       TYK= DMIN* TYK+ TERK* SABJ
  3088.       TZK= DMIN* TZK+ TERK* SALPR
  3089.       TERS=( TXS* CABJ+ TYS* SABJ+ TZS* SALPR)* PX
  3090.       TXS= DMIN* TXS+ TERS* CABJ
  3091.       TYS= DMIN* TYS+ TERS* SABJ
  3092.       TZS= DMIN* TZS+ TERS* SALPR
  3093.       TERC=( TXC* CABJ+ TYC* SABJ+ TZC* SALPR)* PX
  3094.       TXC= DMIN* TXC+ TERC* CABJ
  3095.       TYC= DMIN* TYC+ TERC* SABJ
  3096.       TZC= DMIN* TZC+ TERC* SALPR
  3097.    22 EXK= EXK+ TXK
  3098.       EYK= EYK+ TYK
  3099.       EZK= EZK+ TZK
  3100.       EXS= EXS+ TXS
  3101.       EYS= EYS+ TYS
  3102.       EZS= EZS+ TZS
  3103.       EXC= EXC+ TXC
  3104.       EYC= EYC+ TYC
  3105.       EZC= EZC+ TZC
  3106.       RETURN
  3107.       END
  3108. C ***
  3109. C     DOUBLE PRECISION 6/4/85
  3110. C
  3111.       SUBROUTINE EKSC( S, Z, RH, XK, IJ, EZS, ERS, EZC, ERC, EZK, ERK)
  3112. C ***
  3113.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  3114. C     COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
  3115. C     THIN WIRE APPROXIMATION.                                          
  3116.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  3117.       COMPLEX  CON, GZ1, GZ2, GP1, GP2, GZP1, GZP2, EZS, ERS, EZC, 
  3118.      &ERC, EZK, ERK
  3119.       COMMON  /TMI/ ZPK, RKB2, IJX
  3120.       DIMENSION  CONX(2)
  3121.       EQUIVALENCE(CONX,CON)
  3122.       DATA   CONX/0.,4.771341189D+0/
  3123.       IJX= IJ
  3124.       ZPK= XK* Z
  3125.       RHK= XK* RH
  3126.       RKB2= RHK* RHK
  3127.       SH=.5* S
  3128.       SHK= XK* SH
  3129.       SS= SIN( SHK)
  3130.       CS= COS( SHK)
  3131.       Z2= SH- Z
  3132.       Z1=-( SH+ Z)
  3133.       CALL GX( Z1, RH, XK, GZ1, GP1)
  3134.       CALL GX( Z2, RH, XK, GZ2, GP2)
  3135.       GZP1= GP1* Z1
  3136.       GZP2= GP2* Z2
  3137.       EZS= CON*(( GZ2- GZ1)* CS* XK-( GZP2+ GZP1)* SS)
  3138.       EZC=- CON*(( GZ2+ GZ1)* SS* XK+( GZP2- GZP1)* CS)
  3139.       ERK= CON*( GP2- GP1)* RH
  3140.       CALL INTX(- SHK, SHK, RHK, IJ, CINT, SINT)
  3141.       EZK=- CON*( GZP2- GZP1+ XK* XK* CMPLX( CINT,- SINT))
  3142.       GZP1= GZP1* Z1
  3143.       GZP2= GZP2* Z2
  3144.       IF( RH.LT.1.D-10) GOTO 1
  3145.       ERS=- CON*(( GZP2+ GZP1+ GZ2+ GZ1)* SS-( Z2* GZ2- Z1* GZ1)* CS* 
  3146.      &XK)/ RH
  3147.       ERC=- CON*(( GZP2- GZP1+ GZ2- GZ1)* CS+( Z2* GZ2+ Z1* GZ1)* SS* 
  3148.      &XK)/ RH
  3149.       RETURN
  3150.     1 ERS=(0.,0.)
  3151.       ERC=(0.,0.)
  3152.       RETURN
  3153.       END
  3154. C ***
  3155. C     DOUBLE PRECISION 6/4/85
  3156. C
  3157.       SUBROUTINE EKSCX( BX, S, Z, RHX, XK, IJ, INX1, INX2, EZS, ERS, 
  3158.      &EZC, ERC, EZK, ERK)
  3159. C ***
  3160. C     COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
  3161. C     EXTENDED THIN WIRE APPROXIMATION.                                 
  3162.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  3163.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  3164.       COMPLEX  CON, GZ1, GZ2, GZP1, GZP2, GR1, GR2, GRP1, GRP2, EZS,
  3165.      & EZC, ERS, ERC, GRK1, GRK2, EZK, ERK, GZZ1, GZZ2
  3166.       COMMON  /TMI/ ZPK, RKB2, IJX
  3167.       DIMENSION  CONX(2)
  3168.       EQUIVALENCE(CONX,CON)
  3169.       DATA   CONX/0.,4.771341189D+0/
  3170.       IF( RHX.LT. BX) GOTO 1
  3171.       RH= RHX
  3172.       B= BX
  3173.       IRA=0
  3174.       GOTO 2
  3175.     1 RH= BX
  3176.       B= RHX
  3177.       IRA=1
  3178.     2 SH=.5* S
  3179.       IJX= IJ
  3180.       ZPK= XK* Z
  3181.       RHK= XK* RH
  3182.       RKB2= RHK* RHK
  3183.       SHK= XK* SH
  3184.       SS= SIN( SHK)
  3185.       CS= COS( SHK)
  3186.       Z2= SH- Z
  3187.       Z1=-( SH+ Z)
  3188.       A2= B* B
  3189.       IF( INX1.EQ.2) GOTO 3
  3190.       CALL GXX( Z1, RH, B, A2, XK, IRA, GZ1, GZP1, GR1, GRP1, GRK1, 
  3191.      &GZZ1)
  3192.       GOTO 4
  3193.     3 CALL GX( Z1, RHX, XK, GZ1, GRK1)
  3194.       GZP1= GRK1* Z1
  3195.       GR1= GZ1/ RHX
  3196.       GRP1= GZP1/ RHX
  3197.       GRK1= GRK1* RHX
  3198.       GZZ1=(0.,0.)
  3199.     4 IF( INX2.EQ.2) GOTO 5
  3200.       CALL GXX( Z2, RH, B, A2, XK, IRA, GZ2, GZP2, GR2, GRP2, GRK2, 
  3201.      &GZZ2)
  3202.       GOTO 6
  3203.     5 CALL GX( Z2, RHX, XK, GZ2, GRK2)
  3204.       GZP2= GRK2* Z2
  3205.       GR2= GZ2/ RHX
  3206.       GRP2= GZP2/ RHX
  3207.       GRK2= GRK2* RHX
  3208.       GZZ2=(0.,0.)
  3209.     6 EZS= CON*(( GZ2- GZ1)* CS* XK-( GZP2+ GZP1)* SS)
  3210.       EZC=- CON*(( GZ2+ GZ1)* SS* XK+( GZP2- GZP1)* CS)
  3211.       ERS=- CON*(( Z2* GRP2+ Z1* GRP1+ GR2+ GR1)* SS-( Z2* GR2- Z1* GR1
  3212.      &)* CS* XK)
  3213.       ERC=- CON*(( Z2* GRP2- Z1* GRP1+ GR2- GR1)* CS+( Z2* GR2+ Z1* GR1
  3214.      &)* SS* XK)
  3215.       ERK= CON*( GRK2- GRK1)
  3216.       CALL INTX(- SHK, SHK, RHK, IJ, CINT, SINT)
  3217.       BK= B* XK
  3218.       BK2= BK* BK*.25
  3219.       EZK=- CON*( GZP2- GZP1+ XK* XK*(1.- BK2)* CMPLX( CINT,- SINT)- 
  3220.      &BK2*( GZZ2- GZZ1))
  3221.       RETURN
  3222.       END
  3223. C ***
  3224. C     DOUBLE PRECISION 6/4/85
  3225. C
  3226.       LOGICAL FUNCTION ENF( NUNIT)
  3227. C ***
  3228. C*********** THIS ROUTINE NOT USED ON VAX **************
  3229. C     IF (EOF,NUNIT) 1,2                                                
  3230.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  3231.     1 ENF=.TRUE.
  3232.       RETURN
  3233.     2 ENF=.FALSE.
  3234.       RETURN
  3235.       END
  3236. C ***
  3237. C     DOUBLE PRECISION 6/4/85
  3238. C
  3239. C     IMPLICIT DOUBLE PRECISION(A-H,O-Z)
  3240. C ***
  3241.       SUBROUTINE ERROR
  3242.       IMPLICIT INTEGER (A-Z)
  3243.       CHARACTER   MSG*80
  3244. CJCB      CALL SYS$GETMSG(%VAL(RMSSTS),MSGLEN,MSG,,,)
  3245. CJCB      CALL ERRSNS( FNUM, RMSSTS, RMSSTV, IUNIT, CNDVAL)
  3246.       CALL STR0PC( MSG, MSG)
  3247.       IND= INDEX( MSG,',')
  3248.       PRINT1 , MSG( IND+2: MSGLEN)
  3249.     1 FORMAT(//,'  ****  ERROR  ****   ',//,5X,A,//)
  3250.       RETURN
  3251.       END
  3252. C ***
  3253. C     DOUBLE PRECISION 6/4/85
  3254. C
  3255.       SUBROUTINE ETMNS( P1, P2, P3, P4, P5, P6, IPR, E)
  3256.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  3257. C ***
  3258. C                                                                       
  3259. C     ETMNS FILLS THE ARRAY E WITH THE NEGATIVE OF THE ELECTRIC FIELD   
  3260. C     INCIDENT ON THE STRUCTURE.  E IS THE RIGHT HAND SIDE OF THE MATRIX
  3261. C     EQUATION.                                                         
  3262. C                                                                       
  3263.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  3264.       COMPLEX  E, CX, CY, CZ, VSANT, TX1, TX2, ER, ET, EZH, ERH, VQD
  3265.      &, VQDS, ZRATI, ZRATI2, RRV, RRH, T1, TT1, TT2, FRATI
  3266.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  3267.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  3268.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  3269.       COMMON  /ANGL/ SALP( NM)
  3270.       COMMON  /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
  3271.      &, IQDS(30), NVQD, NSANT, NQDS
  3272.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  3273.      &KSYMP, IFAR, IPERF, T1, T2
  3274.       DIMENSION  CAB(1), SAB(1), E( N2M)
  3275.       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  3276.       EQUIVALENCE(CAB,ALP),(SAB,BET)
  3277.       EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
  3278.      &T2Z,ITAG)
  3279.       DATA   TP/6.283185308D+0/, RETA/2.654420938D-3/
  3280.       NEQ= N+2* M
  3281.       NQDS=0
  3282. C                                                                       
  3283. C     APPLIED FIELD OF VOLTAGE SOURCES FOR TRANSMITTING CASE            
  3284. C                                                                       
  3285.       IF( IPR.GT.0.AND. IPR.NE.5) GOTO 5
  3286.       DO 1  I=1, NEQ
  3287.     1 E( I)=(0.,0.)
  3288.       IF( NSANT.EQ.0) GOTO 3
  3289.       DO 2  I=1, NSANT
  3290.       IS= ISANT( I)
  3291.     2 E( IS)=- VSANT( I)/( SI( IS)* WLAM)
  3292.     3 IF( NVQD.EQ.0) RETURN
  3293.       DO 4  I=1, NVQD
  3294.       IS= IVQD( I)
  3295.     4 CALL QDSRC( IS, VQD( I), E)
  3296.       RETURN
  3297. C                                                                       
  3298. C     INCIDENT PLANE WAVE, LINEARLY POLARIZED.                          
  3299. C                                                                       
  3300.     5 IF( IPR.GT.3) GOTO 19
  3301.       CTH= COS( P1)
  3302.       STH= SIN( P1)
  3303.       CPH= COS( P2)
  3304.       SPH= SIN( P2)
  3305.       CET= COS( P3)
  3306.       SET= SIN( P3)
  3307.       PX= CTH* CPH* CET- SPH* SET
  3308.       PY= CTH* SPH* CET+ CPH* SET
  3309.       PZ=- STH* CET
  3310.       WX=- STH* CPH
  3311.       WY=- STH* SPH
  3312.       WZ=- CTH
  3313.       QX= WY* PZ- WZ* PY
  3314.       QY= WZ* PX- WX* PZ
  3315.       QZ= WX* PY- WY* PX
  3316.       IF( KSYMP.EQ.1) GOTO 7
  3317.       IF( IPERF.EQ.1) GOTO 6
  3318.       RRV= SQRT(1.- ZRATI* ZRATI* STH* STH)
  3319.       RRH= ZRATI* CTH
  3320.       RRH=( RRH- RRV)/( RRH+ RRV)
  3321.       RRV= ZRATI* RRV
  3322.       RRV=-( CTH- RRV)/( CTH+ RRV)
  3323.       GOTO 7
  3324.     6 RRV=-(1.,0.)
  3325.       RRH=-(1.,0.)
  3326.     7 IF( IPR.GT.1) GOTO 13
  3327.       IF( N.EQ.0) GOTO 10
  3328.       DO 8  I=1, N
  3329.       ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I))
  3330.     8 E( I)=-( PX* CAB( I)+ PY* SAB( I)+ PZ* SALP( I))* CMPLX( COS( ARG
  3331.      &), SIN( ARG))
  3332.       IF( KSYMP.EQ.1) GOTO 10
  3333.       TT1=( PY* CPH- PX* SPH)*( RRH- RRV)
  3334.       CX= RRV* PX- TT1* SPH
  3335.       CY= RRV* PY+ TT1* CPH
  3336.       CZ=- RRV* PZ
  3337.       DO 9  I=1, N
  3338.       ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I))
  3339.     9 E( I)= E( I)-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I))* CMPLX( 
  3340.      &COS( ARG), SIN( ARG))
  3341.    10 IF( M.EQ.0) RETURN
  3342.       I= LD+1
  3343.       I1= N-1
  3344.       DO 11  IS=1, M
  3345.       I= I-1
  3346.       I1= I1+2
  3347.       I2= I1+1
  3348.       ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I))
  3349.       TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA
  3350.       E( I2)=( QX* T1X( I)+ QY* T1Y( I)+ QZ* T1Z( I))* TT1
  3351.    11 E( I1)=( QX* T2X( I)+ QY* T2Y( I)+ QZ* T2Z( I))* TT1
  3352.       IF( KSYMP.EQ.1) RETURN
  3353.       TT1=( QY* CPH- QX* SPH)*( RRV- RRH)
  3354.       CX=-( RRH* QX- TT1* SPH)
  3355.       CY=-( RRH* QY+ TT1* CPH)
  3356.       CZ= RRH* QZ
  3357.       I= LD+1
  3358.       I1= N-1
  3359.       DO 12  IS=1, M
  3360.       I= I-1
  3361.       I1= I1+2
  3362.       I2= I1+1
  3363.       ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I))
  3364.       TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA
  3365.       E( I2)= E( I2)+( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT1
  3366.    12 E( I1)= E( I1)+( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT1
  3367. C                                                                       
  3368. C     INCIDENT PLANE WAVE, ELLIPTIC POLARIZATION.                       
  3369. C                                                                       
  3370.       RETURN
  3371.    13 TT1=-(0.,1.)* P6
  3372.       IF( IPR.EQ.3) TT1=- TT1
  3373.       IF( N.EQ.0) GOTO 16
  3374.       CX= PX+ TT1* QX
  3375.       CY= PY+ TT1* QY
  3376.       CZ= PZ+ TT1* QZ
  3377.       DO 14  I=1, N
  3378.       ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I))
  3379.    14 E( I)=-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I))* CMPLX( COS( ARG
  3380.      &), SIN( ARG))
  3381.       IF( KSYMP.EQ.1) GOTO 16
  3382.       TT2=( CY* CPH- CX* SPH)*( RRH- RRV)
  3383.       CX= RRV* CX- TT2* SPH
  3384.       CY= RRV* CY+ TT2* CPH
  3385.       CZ=- RRV* CZ
  3386.       DO 15  I=1, N
  3387.       ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I))
  3388.    15 E( I)= E( I)-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I))* CMPLX( 
  3389.      &COS( ARG), SIN( ARG))
  3390.    16 IF( M.EQ.0) RETURN
  3391.       CX= QX- TT1* PX
  3392.       CY= QY- TT1* PY
  3393.       CZ= QZ- TT1* PZ
  3394.       I= LD+1
  3395.       I1= N-1
  3396.       DO 17  IS=1, M
  3397.       I= I-1
  3398.       I1= I1+2
  3399.       I2= I1+1
  3400.       ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I))
  3401.       TT2= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA
  3402.       E( I2)=( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT2
  3403.    17 E( I1)=( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT2
  3404.       IF( KSYMP.EQ.1) RETURN
  3405.       TT1=( CY* CPH- CX* SPH)*( RRV- RRH)
  3406.       CX=-( RRH* CX- TT1* SPH)
  3407.       CY=-( RRH* CY+ TT1* CPH)
  3408.       CZ= RRH* CZ
  3409.       I= LD+1
  3410.       I1= N-1
  3411.       DO 18  IS=1, M
  3412.       I= I-1
  3413.       I1= I1+2
  3414.       I2= I1+1
  3415.       ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I))
  3416.       TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA
  3417.       E( I2)= E( I2)+( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT1
  3418.    18 E( I1)= E( I1)+( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT1
  3419. C                                                                       
  3420. C     INCIDENT FIELD OF AN ELEMENTARY CURRENT SOURCE.                   
  3421. C                                                                       
  3422.       RETURN
  3423.    19 WZ= COS( P4)
  3424.       WX= WZ* COS( P5)
  3425.       WY= WZ* SIN( P5)
  3426.       WZ= SIN( P4)
  3427.       DS= P6*59.958
  3428.       DSH= P6/(2.* TP)
  3429.       NPM= N+ M
  3430.       IS= LD+1
  3431.       I1= N-1
  3432.       DO 24  I=1, NPM
  3433.       II= I
  3434.       IF( I.LE. N) GOTO 20
  3435.       IS= IS-1
  3436.       II= IS
  3437.       I1= I1+2
  3438.       I2= I1+1
  3439.    20 PX= X( II)- P1
  3440.       PY= Y( II)- P2
  3441.       PZ= Z( II)- P3
  3442.       RS= PX* PX+ PY* PY+ PZ* PZ
  3443.       IF( RS.LT.1.D-30) GOTO 24
  3444.       R= SQRT( RS)
  3445.       PX= PX/ R
  3446.       PY= PY/ R
  3447.       PZ= PZ/ R
  3448.       CTH= PX* WX+ PY* WY+ PZ* WZ
  3449.       STH= SQRT(1.- CTH* CTH)
  3450.       QX= PX- WX* CTH
  3451.       QY= PY- WY* CTH
  3452.       QZ= PZ- WZ* CTH
  3453.       ARG= SQRT( QX* QX+ QY* QY+ QZ* QZ)
  3454.       IF( ARG.LT.1.D-30) GOTO 21
  3455.       QX= QX/ ARG
  3456.       QY= QY/ ARG
  3457.       QZ= QZ/ ARG
  3458.       GOTO 22
  3459.    21 QX=1.
  3460.       QY=0.
  3461.       QZ=0.
  3462.    22 ARG=- TP* R
  3463.       TT1= CMPLX( COS( ARG), SIN( ARG))
  3464.       IF( I.GT. N) GOTO 23
  3465.       TT2= CMPLX(1.D+0,-1.D+0/( R* TP))/ RS
  3466.       ER= DS* TT1* TT2* CTH
  3467.       ET=.5* DS* TT1*((0.,1.)* TP/ R+ TT2)* STH
  3468.       EZH= ER* CTH- ET* STH
  3469.       ERH= ER* STH+ ET* CTH
  3470.       CX= EZH* WX+ ERH* QX
  3471.       CY= EZH* WY+ ERH* QY
  3472.       CZ= EZH* WZ+ ERH* QZ
  3473.       E( I)=-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I))
  3474.       GOTO 24
  3475.    23 PX= WY* QZ- WZ* QY
  3476.       PY= WZ* QX- WX* QZ
  3477.       PZ= WX* QY- WY* QX
  3478.       TT2= DSH* TT1* CMPLX(1./ R, TP)/ R* STH* SALP( II)
  3479.       CX= TT2* PX
  3480.       CY= TT2* PY
  3481.       CZ= TT2* PZ
  3482.       E( I2)= CX* T1X( II)+ CY* T1Y( II)+ CZ* T1Z( II)
  3483.       E( I1)= CX* T2X( II)+ CY* T2Y( II)+ CZ* T2Z( II)
  3484.    24 CONTINUE
  3485.       RETURN
  3486.       END
  3487. C ***
  3488. C     DOUBLE PRECISION 6/4/85
  3489. C
  3490.       SUBROUTINE FACGF( A, B, C, D, BX, IP, IX, NP, N1, MP, M1, N1C, 
  3491.      &N2C)
  3492. C ***
  3493. C     FACGF COMPUTES AND FACTORS D-C(INV(A)B).                          
  3494.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  3495.       COMPLEX  A, B, C, D, BX, SUM
  3496.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  3497.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  3498.       DIMENSION  A(1), B( N1C,1), C( N1C,1), D( N2C,1), BX( N1C,1), IP(
  3499.      &1), IX(1)
  3500.       IF( N2C.EQ.0) RETURN
  3501.       IBFL=14
  3502. C     CONVERT B FROM BLOCKS OF ROWS ON T14 TO BLOCKS OF COL. ON T16     
  3503.       IF( ICASX.LT.3) GOTO 1
  3504.       CALL REBLK( B, C, N1C, NPBX, N2C)
  3505.       IBFL=16
  3506.     1 NPB= NPBL
  3507. C     COMPUTE INV(A)B AND WRITE ON TAPE14                               
  3508.       IF( ICASX.EQ.2) REWIND 14
  3509.       DO 2  IB=1, NBBL
  3510.       IF( IB.EQ. NBBL) NPB= NLBL
  3511.       IF( ICASX.GT.1) READ( IBFL) (( BX( I, J), I=1, N1C), J=1, NPB)
  3512.       CALL SOLVES( A, IP, BX, N1C, NPB, NP, N1, MP, M1,13,13)
  3513.       IF( ICASX.EQ.2) REWIND 14
  3514.       IF( ICASX.GT.1) WRITE( 14) (( BX( I, J), I=1, N1C), J=1, NPB)
  3515.     2 CONTINUE
  3516.       IF( ICASX.EQ.1) GOTO 3
  3517.       REWIND 11
  3518.       REWIND 12
  3519.       REWIND 15
  3520.       REWIND IBFL
  3521. C     COMPUTE D-C(INV(A)B) AND WRITE ON TAPE11                          
  3522.     3 NPC= NPBL
  3523.       DO 8  IC=1, NBBL
  3524.       IF( IC.EQ. NBBL) NPC= NLBL
  3525.       IF( ICASX.EQ.1) GOTO 4
  3526.       READ( 15) (( C( I, J), I=1, N1C), J=1, NPC)
  3527.       READ( 12) (( D( I, J), I=1, N2C), J=1, NPC)
  3528.       REWIND 14
  3529.     4 NPB= NPBL
  3530.       NIC=0
  3531.       DO 7  IB=1, NBBL
  3532.       IF( IB.EQ. NBBL) NPB= NLBL
  3533.       IF( ICASX.GT.1) READ( 14) (( B( I, J), I=1, N1C), J=1, NPB)
  3534.       DO 6  I=1, NPB
  3535.       II= I+ NIC
  3536.       DO 6  J=1, NPC
  3537.       SUM=(0.,0.)
  3538.       DO 5  K=1, N1C
  3539.     5 SUM= SUM+ B( K, I)* C( K, J)
  3540.     6 D( II, J)= D( II, J)- SUM
  3541.     7 NIC= NIC+ NPBL
  3542.       IF( ICASX.GT.1) WRITE( 11) (( D( I, J), I=1, N2C), J=1, NPBL)
  3543.     8 CONTINUE
  3544.       IF( ICASX.EQ.1) GOTO 9
  3545.       REWIND 11
  3546.       REWIND 12
  3547.       REWIND 14
  3548.       REWIND 15
  3549. C     FACTOR D-C(INV(A)B)                                               
  3550.     9 N1CP= N1C+1
  3551.       IF( ICASX.GT.1) GOTO 10
  3552.       CALL FACTR( N2C, D, IP( N1CP), N2C)
  3553.       GOTO 13
  3554.    10 IF( ICASX.EQ.4) GOTO 12
  3555.       NPB= NPBL
  3556.       IC=0
  3557.       DO 11  IB=1, NBBL
  3558.       IF( IB.EQ. NBBL) NPB= NLBL
  3559.       II= IC+1
  3560.       IC= IC+ N2C* NPB
  3561.    11 READ( 11) ( B( I,1), I= II, IC)
  3562.       REWIND 11
  3563.       CALL FACTR( N2C, B, IP( N1CP), N2C)
  3564.       NIC= N2C* N2C
  3565.       WRITE( 11) ( B( I,1), I=1, NIC)
  3566.       REWIND 11
  3567.       GOTO 13
  3568.    12 NBLSYS= NBLSYM
  3569.       NPSYS= NPSYM
  3570.       NLSYS= NLSYM
  3571.       ICASS= ICASE
  3572.       NBLSYM= NBBL
  3573.       NPSYM= NPBL
  3574.       NLSYM= NLBL
  3575.       ICASE=3
  3576.       CALL FACIO( B, N2C,1, IX( N1CP),11,12,16,11)
  3577.       CALL LUNSCR( B, N2C,1, IP( N1CP), IX( N1CP),12,11,16)
  3578.       NBLSYM= NBLSYS
  3579.       NPSYM= NPSYS
  3580.       NLSYM= NLSYS
  3581.       ICASE= ICASS
  3582.    13 RETURN
  3583.       END
  3584. C ***
  3585. C     DOUBLE PRECISION 6/4/85
  3586. C
  3587.       SUBROUTINE FACIO( A, NROW, NOP, IP, IU1, IU2, IU3, IU4)
  3588. C ***
  3589. C                                                                       
  3590. C     FACIO CONTROLS I/O FOR OUT-OF-CORE FACTORIZATION                  
  3591. C                                                                       
  3592.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  3593.       COMPLEX  A
  3594.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  3595.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  3596.       DIMENSION  A( NROW,1), IP( NROW)
  3597.       IT=2* NPSYM* NROW
  3598.       NBM= NBLSYM-1
  3599.       I1=1
  3600.       I2= IT
  3601.       I3= I2+1
  3602.       I4=2* IT
  3603.       TIME=0.
  3604.       REWIND IU1
  3605.       REWIND IU2
  3606.       DO 3  KK=1, NOP
  3607.       KA=( KK-1)* NROW+1
  3608.       IFILE3= IU1
  3609.       IFILE4= IU3
  3610.       DO 2  IXBLK1=1, NBM
  3611.       REWIND IU3
  3612.       REWIND IU4
  3613.       CALL BLCKIN( A, IFILE3, I1, I2,1,17)
  3614.       IXBP= IXBLK1+1
  3615.       DO 1  IXBLK2= IXBP, NBLSYM
  3616.       CALL BLCKIN( A, IFILE3, I3, I4,1,18)
  3617.       CALL SECNDS( T1)
  3618.       CALL LFACTR( A, NROW, IXBLK1, IXBLK2, IP( KA))
  3619.       CALL SECNDS( T2)
  3620.       TIME= TIME+ T2- T1
  3621.       IF( IXBLK2.EQ. IXBP) CALL BLCKOT( A, IU2, I1, I2,1,19)
  3622.       IF( IXBLK1.EQ. NBM.AND. IXBLK2.EQ. NBLSYM) IFILE4= IU2
  3623.       CALL BLCKOT( A, IFILE4, I3, I4,1,20)
  3624.     1 CONTINUE
  3625.       IFILE3= IU3
  3626.       IFILE4= IU4
  3627.       IF(( IXBLK1/2)*2.NE. IXBLK1) GOTO 2
  3628.       IFILE3= IU4
  3629.       IFILE4= IU3
  3630.     2 CONTINUE
  3631.     3 CONTINUE
  3632.       REWIND IU1
  3633.       REWIND IU2
  3634.       REWIND IU3
  3635.       REWIND IU4
  3636.       WRITE( 6,4)  TIME
  3637. C                                                                       
  3638.       RETURN
  3639.     4 FORMAT(' CP TIME TAKEN FOR FACTORIZATION = ',1P,E12.5)
  3640.       END
  3641. C ***
  3642. C     DOUBLE PRECISION 6/4/85
  3643. C
  3644.       SUBROUTINE FACTR( N, A, IP, NDIM)
  3645. C ***
  3646. C                                                                       
  3647. C     SUBROUTINE TO FACTOR A MATRIX INTO A UNIT LOWER TRIANGULAR MATRIX 
  3648. C     AND AN UPPER TRIANGULAR MATRIX USING THE GAUSS-DOOLITTLE ALGORITHM
  3649. C     PRESENTED ON PAGES 411-416 OF A. RALSTON--A FIRST COURSE IN       
  3650. C     NUMERICAL ANALYSIS.  COMMENTS BELOW REFER TO COMMENTS IN RALSTONS 
  3651. C     TEXT.    (MATRIX TRANSPOSED.                                      
  3652. C                                                                       
  3653.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  3654.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  3655.       COMPLEX  A, D, ARJ
  3656.       DIMENSION  A( NDIM, NDIM), IP( NDIM)
  3657.       COMMON  /SCRATM/ D( N2M)
  3658.       INTEGER  R, RM1, RP1, PJ, PR
  3659.       IFLG=0
  3660. C                                                                       
  3661. C     STEP 1                                                            
  3662. C                                                                       
  3663.       DO 9  R=1, N
  3664.       DO 1  K=1, N
  3665.       D( K)= A( R, K)
  3666. C                                                                       
  3667. C     STEPS 2 AND 3                                                     
  3668. C                                                                       
  3669.     1 CONTINUE
  3670.       RM1= R-1
  3671.       IF( RM1.LT.1) GOTO 4
  3672.       DO 3  J=1, RM1
  3673.       PJ= IP( J)
  3674.       ARJ= D( PJ)
  3675.       A( R, J)= ARJ
  3676.       D( PJ)= D( J)
  3677.       JP1= J+1
  3678.       DO 2  I= JP1, N
  3679.       D( I)= D( I)- A( J, I)* ARJ
  3680.     2 CONTINUE
  3681.     3 CONTINUE
  3682. C                                                                       
  3683. C     STEP 4                                                            
  3684. C                                                                       
  3685.     4 CONTINUE
  3686.       DMAX= REAL( D( R)* CONJG( D( R)))
  3687.       IP( R)= R
  3688.       RP1= R+1
  3689.       IF( RP1.GT. N) GOTO 6
  3690.       DO 5  I= RP1, N
  3691.       ELMAG= REAL( D( I)* CONJG( D( I)))
  3692.       IF( ELMAG.LT. DMAX) GOTO 5
  3693.       DMAX= ELMAG
  3694.       IP( R)= I
  3695.     5 CONTINUE
  3696.     6 CONTINUE
  3697.       IF( DMAX.LT.1.D-10) IFLG=1
  3698.       PR= IP( R)
  3699.       A( R, R)= D( PR)
  3700. C                                                                       
  3701. C     STEP 5                                                            
  3702. C                                                                       
  3703.       D( PR)= D( R)
  3704.       IF( RP1.GT. N) GOTO 8
  3705.       ARJ=1./ A( R, R)
  3706.       DO 7  I= RP1, N
  3707.       A( R, I)= D( I)* ARJ
  3708.     7 CONTINUE
  3709.     8 CONTINUE
  3710.       IF( IFLG.EQ.0) GOTO 9
  3711.       WRITE( 6,10)  R, DMAX
  3712.       IFLG=0
  3713.     9 CONTINUE
  3714. C                                                                       
  3715.       RETURN
  3716.    10 FORMAT(1H ,'PIVOT(',I3,')=',1P,E16.8)
  3717.       END
  3718. C ***
  3719. C     DOUBLE PRECISION 6/4/85
  3720. C
  3721.       SUBROUTINE FACTRS( NP, NROW, A, IP, IX, IU1, IU2, IU3, IU4)
  3722. C ***
  3723. C                                                                       
  3724. C     FACTRS, FOR SYMMETRIC STRUCTURE, TRANSFORMS SUBMATRICIES TO FORM  
  3725. C     MATRICIES OF THE SYMMETRIC MODES AND CALLS ROUTINE TO FACTOR      
  3726. C     MATRICIES.  IF NO SYMMETRY, THE ROUTINE IS CALLED TO FACTOR THE   
  3727. C     COMPLETE MATRIX.                                                  
  3728. C                                                                       
  3729.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  3730.       COMPLEX  A
  3731.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  3732.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  3733.       DIMENSION  A(1), IP( NROW), IX( NROW)
  3734.       NOP= NROW/ NP
  3735.       IF( ICASE.GT.2) GOTO 2
  3736.       DO 1  KK=1, NOP
  3737.       KA=( KK-1)* NP+1
  3738.     1 CALL FACTR( NP, A( KA), IP( KA), NROW)
  3739.       RETURN
  3740. C                                                                       
  3741. C     FACTOR SUBMATRICIES, OR FACTOR COMPLETE MATRIX IF NO SYMMETRY     
  3742. C     EXISTS.                                                           
  3743. C                                                                       
  3744.     2 IF( ICASE.GT.3) GOTO 3
  3745.       CALL FACIO( A, NROW, NOP, IX, IU1, IU2, IU3, IU4)
  3746.       CALL LUNSCR( A, NROW, NOP, IP, IX, IU2, IU3, IU4)
  3747. C                                                                       
  3748. C     REWRITE THE MATRICES BY COLUMNS ON TAPE 13                        
  3749. C                                                                       
  3750.       RETURN
  3751.     3 I2=2* NPBLK* NROW
  3752.       REWIND IU2
  3753.       DO 5  K=1, NOP
  3754.       REWIND IU1
  3755.       ICOLS= NPBLK
  3756.       IR2= K* NP
  3757.       IR1= IR2- NP+1
  3758.       DO 5  L=1, NBLOKS
  3759.       IF( NBLOKS.EQ.1.AND. K.GT.1) GOTO 4
  3760.       CALL BLCKIN( A, IU1,1, I2,1,602)
  3761.       IF( L.EQ. NBLOKS) ICOLS= NLAST
  3762.     4 IRR1= IR1
  3763.       IRR2= IR2
  3764.       DO 5  ICOLDX=1, ICOLS
  3765.       WRITE( IU2) ( A( I), I= IRR1, IRR2)
  3766.       IRR1= IRR1+ NROW
  3767.       IRR2= IRR2+ NROW
  3768.     5 CONTINUE
  3769.       REWIND IU1
  3770.       REWIND IU2
  3771.       IF( ICASE.EQ.5) GOTO 8
  3772.       REWIND IU3
  3773.       IRR1= NP* NP
  3774.       DO 7  KK=1, NOP
  3775.       IR1=1- NP
  3776.       IR2=0
  3777.       DO 6  I=1, NP
  3778.       IR1= IR1+ NP
  3779.       IR2= IR2+ NP
  3780.     6 READ( IU2) ( A( J), J= IR1, IR2)
  3781.       KA=( KK-1)* NP+1
  3782.       CALL FACTR( NP, A, IP( KA), NP)
  3783.       WRITE( IU3) ( A( I), I=1, IRR1)
  3784.     7 CONTINUE
  3785.       REWIND IU2
  3786.       REWIND IU3
  3787.       RETURN
  3788.     8 I2=2* NPSYM* NP
  3789.       DO 10  KK=1, NOP
  3790.       J2= NPSYM
  3791.       DO 10  L=1, NBLSYM
  3792.       IF( L.EQ. NBLSYM) J2= NLSYM
  3793.       IR1=1- NP
  3794.       IR2=0
  3795.       DO 9  J=1, J2
  3796.       IR1= IR1+ NP
  3797.       IR2= IR2+ NP
  3798.     9 READ( IU2) ( A( I), I= IR1, IR2)
  3799.    10 CALL BLCKOT( A, IU1,1, I2,1,193)
  3800.       REWIND IU1
  3801.       CALL FACIO( A, NP, NOP, IX, IU1, IU2, IU3, IU4)
  3802.       CALL LUNSCR( A, NP, NOP, IP, IX, IU2, IU3, IU4)
  3803.       RETURN
  3804.       END
  3805. C ***
  3806. C     DOUBLE PRECISION 6/4/85
  3807. C
  3808. Cjcb      COMPLEX FUNCTION FBAR( P)
  3809.       FUNCTION FBAR( P)
  3810. C ***
  3811. C                                                                       
  3812. C     FBAR IS SOMMERFELD ATTENUATION FUNCTION FOR NUMERICAL DISTANCE P  
  3813. C                                                                       
  3814. Cjcb      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  3815.       COMPLEX  Z, ZS, SUM, POW, TERM, P, FJ, FBAR
  3816.       DIMENSION  FJX(2)
  3817.       EQUIVALENCE(FJ,FJX)
  3818.       DATA   TOSP/1.128379167D+0/, ACCS/1.D-12/, SP/1.772453851D+0/, 
  3819.      &FJX/0.,1./
  3820.       Z= FJ* SQRT( P)
  3821. C                                                                       
  3822. C     SERIES EXPANSION                                                  
  3823. C                                                                       
  3824.       IF( ABS( Z).GT.3.) GOTO 3
  3825.       ZS= Z* Z
  3826.       SUM= Z
  3827.       POW= Z
  3828.       DO 1  I=1,100
  3829.       POW=- POW* ZS/ DFLOAT( I)
  3830.       TERM= POW/(2.* I+1.)
  3831.       SUM= SUM+ TERM
  3832.       TMS= REAL( TERM* CONJG( TERM))
  3833.       SMS= REAL( SUM* CONJG( SUM))
  3834.       IF( TMS/ SMS.LT. ACCS) GOTO 2
  3835.     1 CONTINUE
  3836.     2 FBAR=1.-(1.- SUM* TOSP)* Z* EXP( ZS)* SP
  3837. C                                                                       
  3838. C     ASYMPTOTIC EXPANSION                                              
  3839. C                                                                       
  3840.       RETURN
  3841.     3 IF( REAL( Z).GE.0.) GOTO 4
  3842.       MINUS=1
  3843.       Z=- Z
  3844.       GOTO 5
  3845.     4 MINUS=0
  3846.     5 ZS=.5/( Z* Z)
  3847.       SUM=(0.,0.)
  3848.       TERM=(1.,0.)
  3849.       DO 6  I=1,6
  3850.       TERM=- TERM*(2.* I-1.)* ZS
  3851.     6 SUM= SUM+ TERM
  3852.       IF( MINUS.EQ.1) SUM= SUM-2.* SP* Z* EXP( Z* Z)
  3853.       FBAR=- SUM
  3854.       RETURN
  3855.       END
  3856. C ***
  3857. C     DOUBLE PRECISION 6/4/85
  3858. C
  3859.       SUBROUTINE FBLOCK( NROW, NCOL, IMAX, IRNGF, IPSYM)
  3860. C ***
  3861. C     FBLOCK SETS PARAMETERS FOR OUT-OF-CORE SOLUTION FOR THE PRIMARY   
  3862. C     MATRIX (A)                                                        
  3863.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  3864.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  3865.       COMPLEX  SSX, DETER
  3866.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  3867.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  3868.       COMMON  /SMAT/ SSX(16,16)
  3869.       IMX1= IMAX- IRNGF
  3870.       IF( NROW* NCOL.GT. IMX1) GOTO 2
  3871.       NBLOKS=1
  3872.       NPBLK= NROW
  3873.       NLAST= NROW
  3874.       IMAT= NROW* NCOL
  3875.       IF( NROW.NE. NCOL) GOTO 1
  3876.       ICASE=1
  3877.       RETURN
  3878.     1 ICASE=2
  3879.       GOTO 5
  3880.     2 IF( NROW.NE. NCOL) GOTO 3
  3881.       ICASE=3
  3882.       NPBLK= IMAX/(2* NCOL)
  3883.       NPSYM= IMX1/ NCOL
  3884.       IF( NPSYM.LT. NPBLK) NPBLK= NPSYM
  3885.       IF( NPBLK.LT.1) GOTO 12
  3886.       NBLOKS=( NROW-1)/ NPBLK
  3887.       NLAST= NROW- NBLOKS* NPBLK
  3888.       NBLOKS= NBLOKS+1
  3889.       NBLSYM= NBLOKS
  3890.       NPSYM= NPBLK
  3891.       NLSYM= NLAST
  3892.       IMAT= NPBLK* NCOL
  3893.       WRITE( 6,14)  NBLOKS, NPBLK, NLAST
  3894.       GOTO 11
  3895.     3 NPBLK= IMAX/ NCOL
  3896.       IF( NPBLK.LT.1) GOTO 12
  3897.       IF( NPBLK.GT. NROW) NPBLK= NROW
  3898.       NBLOKS=( NROW-1)/ NPBLK
  3899.       NLAST= NROW- NBLOKS* NPBLK
  3900.       NBLOKS= NBLOKS+1
  3901.       WRITE( 6,14)  NBLOKS, NPBLK, NLAST
  3902.       IF( NROW* NROW.GT. IMX1) GOTO 4
  3903.       ICASE=4
  3904.       NBLSYM=1
  3905.       NPSYM= NROW
  3906.       NLSYM= NROW
  3907.       IMAT= NROW* NROW
  3908.       WRITE( 6,15) 
  3909.       GOTO 5
  3910.     4 ICASE=5
  3911.       NPSYM= IMAX/(2* NROW)
  3912.       NBLSYM= IMX1/ NROW
  3913.       IF( NBLSYM.LT. NPSYM) NPSYM= NBLSYM
  3914.       IF( NPSYM.LT.1) GOTO 12
  3915.       NBLSYM=( NROW-1)/ NPSYM
  3916.       NLSYM= NROW- NBLSYM* NPSYM
  3917.       NBLSYM= NBLSYM+1
  3918.       WRITE( 6,16)  NBLSYM, NPSYM, NLSYM
  3919.       IMAT= NPSYM* NROW
  3920.     5 NOP= NCOL/ NROW
  3921.       IF( NOP* NROW.NE. NCOL) GOTO 13
  3922. C                                                                       
  3923. C     SET UP SSX MATRIX FOR ROTATIONAL SYMMETRY.                        
  3924. C                                                                       
  3925.       IF( IPSYM.GT.0) GOTO 7
  3926.       PHAZ=6.2831853072D+0/ NOP
  3927.       DO 6  I=2, NOP
  3928.       DO 6  J= I, NOP
  3929.       ARG= PHAZ* DFLOAT( I-1)* DFLOAT( J-1)
  3930.       SSX( I, J)= CMPLX( COS( ARG), SIN( ARG))
  3931.     6 SSX( J, I)= SSX( I, J)
  3932. C                                                                       
  3933. C     SET UP SSX MATRIX FOR PLANE SYMMETRY                              
  3934. C                                                                       
  3935.       GOTO 11
  3936.     7 KK=1
  3937.       SSX(1,1)=(1.,0.)
  3938.       IF(( NOP.EQ.2).OR.( NOP.EQ.4).OR.( NOP.EQ.8)) GOTO 8
  3939.       STOP
  3940.     8 KA= NOP/2
  3941.       IF( NOP.EQ.8) KA=3
  3942.       DO 10  K=1, KA
  3943.       DO 9  I=1, KK
  3944.       DO 9  J=1, KK
  3945.       DETER= SSX( I, J)
  3946.       SSX( I, J+ KK)= DETER
  3947.       SSX( I+ KK, J+ KK)=- DETER
  3948.     9 SSX( I+ KK, J)= DETER
  3949.    10 KK= KK*2
  3950.    11 RETURN
  3951.    12 WRITE( 6,17)  NROW, NCOL
  3952.       STOP
  3953.    13 WRITE( 6,18)  NROW, NCOL
  3954. C                                                                       
  3955.       STOP
  3956.    14 FORMAT(//' MATRIX FILE STORAGE -  NO. BLOCKS=',I5,' COLUMNS PE',
  3957.      &'R BLOCK=',I5,' COLUMNS IN LAST BLOCK=',I5)
  3958.    15 FORMAT(' SUBMATRICIES FIT IN CORE')
  3959.    16 FORMAT(' SUBMATRIX PARTITIONING -  NO. BLOCKS=',I5,' COLUMNS P',
  3960.      &'ER BLOCK=',I5,' COLUMNS IN LAST BLOCK=',I5)
  3961.    17 FORMAT(' ERROR - INSUFFICIENT STORAGE FOR MATRIX',2I5)
  3962.    18 FORMAT(' SYMMETRY ERROR - NROW,NCOL=',2I5)
  3963.       END
  3964. C ***
  3965. C     DOUBLE PRECISION 6/4/85
  3966. C
  3967.       SUBROUTINE FBNGF( NEQ, NEQ2, IRESRV, IB11, IC11, ID11, IX11)
  3968. C ***
  3969. C     FBNGF SETS THE BLOCKING PARAMETERS FOR THE B, C, AND D ARRAYS FOR 
  3970. C     OUT-OF-CORE STORAGE.                                              
  3971.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  3972.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  3973.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  3974.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  3975.       IRESX= IRESRV- IMAT
  3976.       NBLN= NEQ* NEQ2
  3977.       NDLN= NEQ2* NEQ2
  3978.       NBCD=2* NBLN+ NDLN
  3979.       IF( NBCD.GT. IRESX) GOTO 1
  3980.       ICASX=1
  3981.       IB11= IMAT+1
  3982.       GOTO 2
  3983.     1 IF( ICASE.LT.3) GOTO 3
  3984.       IF( NBCD.GT. IRESRV.OR. NBLN.GT. IRESX) GOTO 3
  3985.       ICASX=2
  3986.       IB11=1
  3987.     2 NBBX=1
  3988.       NPBX= NEQ
  3989.       NLBX= NEQ
  3990.       NBBL=1
  3991.       NPBL= NEQ2
  3992.       NLBL= NEQ2
  3993.       GOTO 5
  3994.     3 IR= IRESRV
  3995.       IF( ICASE.LT.3) IR= IRESX
  3996.       ICASX=3
  3997.       IF( NDLN.GT. IR) ICASX=4
  3998.       NBCD=2* NEQ+ NEQ2
  3999.       NPBL= IR/ NBCD
  4000.       NLBL= IR/(2* NEQ2)
  4001.       IF( NLBL.LT. NPBL) NPBL= NLBL
  4002.       IF( ICASE.LT.3) GOTO 4
  4003.       NLBL= IRESX/ NEQ
  4004.       IF( NLBL.LT. NPBL) NPBL= NLBL
  4005.     4 IF( NPBL.LT.1) GOTO 6
  4006.       NBBL=( NEQ2-1)/ NPBL
  4007.       NLBL= NEQ2- NBBL* NPBL
  4008.       NBBL= NBBL+1
  4009.       NBLN= NEQ* NPBL
  4010.       IR= IR- NBLN
  4011.       NPBX= IR/ NEQ2
  4012.       IF( NPBX.GT. NEQ) NPBX= NEQ
  4013.       NBBX=( NEQ-1)/ NPBX
  4014.       NLBX= NEQ- NBBX* NPBX
  4015.       NBBX= NBBX+1
  4016.       IB11=1
  4017.       IF( ICASE.LT.3) IB11= IMAT+1
  4018.     5 IC11= IB11+ NBLN
  4019.       ID11= IC11+ NBLN
  4020.       IX11= IMAT+1
  4021.       WRITE( 6,11)  NEQ2
  4022.       IF( ICASX.EQ.1) RETURN
  4023.       WRITE( 6,8)  ICASX
  4024.       WRITE( 6,9)  NBBX, NPBX, NLBX
  4025.       WRITE( 6,10)  NBBL, NPBL, NLBL
  4026.       RETURN
  4027.     6 WRITE( 6,7)  IRESRV, IMAT, NEQ, NEQ2
  4028. C                                                                       
  4029.       STOP
  4030.     7 FORMAT(55H ERROR - INSUFFICIENT STORAGE FOR INTERACTION MATRICIES
  4031.      &,'  IRESRV,IMAT,NEQ,NEQ2 =',4I5)
  4032.     8 FORMAT(48H FILE STORAGE FOR NEW MATRIX SECTIONS -  ICASX =,I2)
  4033.     9 FORMAT(' B FILLED BY ROWS -',15X,'NO. BLOCKS =',I3,3X,'ROWS P',
  4034.      &'ER BLOCK =',I3,3X,'ROWS IN LAST BLOCK =',I3)
  4035.    10 FORMAT(32H B BY COLUMNS, C AND D BY ROWS -,2X,12HNO. BLOCKS =,I3,
  4036.      &4X,15HR/C PER BLOCK =,I3,4X,19HR/C IN LAST BLOCK =,I3)
  4037.    11 FORMAT(//,35H N.G.F. - NUMBER OF NEW UNKNOWNS IS,I4)
  4038.       END
  4039. C ***
  4040. C     DOUBLE PRECISION 6/4/85
  4041. C
  4042.       SUBROUTINE FFLD( THET, PHI, ETH, EPH)
  4043. C ***
  4044. C                                                                       
  4045. C     FFLD CALCULATES THE FAR ZONE RADIATED ELECTRIC FIELDS,            
  4046. C     THE FACTOR EXP(J*K*R)/(R/LAMDA) NOT INCLUDED                      
  4047. C                                                                       
  4048.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  4049.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  4050.       COMPLEX  CIX, CIY, CIZ, EXA, ETH, EPH, CONST, CCX, CCY, CCZ, 
  4051.      &CDP, CUR
  4052.       COMPLEX  ZRATI, ZRSIN, RRV, RRH, RRV1, RRH1, RRV2, RRH2, 
  4053.      &ZRATI2, TIX, TIY, TIZ, T1, ZSCRN, EX, EY, EZ, GX, GY, GZ, FRATI
  4054.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  4055.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  4056.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  4057.       COMMON  /ANGL/ SALP( NM)
  4058.       COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM), 
  4059.      &CII( NM), CUR( N3M)
  4060.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  4061.      &KSYMP, IFAR, IPERF, T1, T2
  4062.       DIMENSION  CAB(1), SAB(1), CONSX(2)
  4063.       EQUIVALENCE(CAB,ALP),(SAB,BET),(CONST,CONSX)
  4064.       DATA   PI, TP, ETA/3.141592654D+0,6.283185308D+0,376.73/
  4065.       DATA   CONSX/0.,-29.97922085D+0/
  4066.       PHX=- SIN( PHI)
  4067.       PHY= COS( PHI)
  4068.       ROZ= COS( THET)
  4069.       ROZS= ROZ
  4070.       THX= ROZ* PHY
  4071.       THY=- ROZ* PHX
  4072.       THZ=- SIN( THET)
  4073.       ROX=- THZ* PHY
  4074.       ROY= THZ* PHX
  4075. C                                                                       
  4076. C     LOOP FOR STRUCTURE IMAGE IF ANY                                   
  4077. C                                                                       
  4078.       IF( N.EQ.0) GOTO 20
  4079. C                                                                       
  4080. C     CALCULATION OF REFLECTION COEFFECIENTS                            
  4081. C                                                                       
  4082.       DO 19  K=1, KSYMP
  4083.       IF( K.EQ.1) GOTO 4
  4084. C                                                                       
  4085. C     FOR PERFECT GROUND                                                
  4086. C                                                                       
  4087.       IF( IPERF.NE.1) GOTO 1
  4088.       RRV=-(1.,0.)
  4089.       RRH=-(1.,0.)
  4090. C                                                                       
  4091. C     FOR INFINITE PLANAR GROUND                                        
  4092. C                                                                       
  4093.       GOTO 2
  4094.     1 ZRSIN= SQRT(1.- ZRATI* ZRATI* THZ* THZ)
  4095.       RRV=-( ROZ- ZRATI* ZRSIN)/( ROZ+ ZRATI* ZRSIN)
  4096.       RRH=( ZRATI* ROZ- ZRSIN)/( ZRATI* ROZ+ ZRSIN)
  4097. C                                                                       
  4098. C     FOR THE CLIFF PROBLEM, TWO REFLCTION COEFFICIENTS CALCULATED      
  4099. C                                                                       
  4100.     2 IF( IFAR.LE.1) GOTO 3
  4101.       RRV1= RRV
  4102.       RRH1= RRH
  4103.       TTHET= TAN( THET)
  4104.       IF( IFAR.EQ.4) GOTO 3
  4105.       ZRSIN= SQRT(1.- ZRATI2* ZRATI2* THZ* THZ)
  4106.       RRV2=-( ROZ- ZRATI2* ZRSIN)/( ROZ+ ZRATI2* ZRSIN)
  4107.       RRH2=( ZRATI2* ROZ- ZRSIN)/( ZRATI2* ROZ+ ZRSIN)
  4108.       DARG=- TP*2.* CH* ROZ
  4109.     3 ROZ=- ROZ
  4110.       CCX= CIX
  4111.       CCY= CIY
  4112.       CCZ= CIZ
  4113.     4 CIX=(0.,0.)
  4114.       CIY=(0.,0.)
  4115. C                                                                       
  4116. C     LOOP OVER STRUCTURE SEGMENTS                                      
  4117. C                                                                       
  4118.       CIZ=(0.,0.)
  4119.       DO 17  I=1, N
  4120.       OMEGA=-( ROX* CAB( I)+ ROY* SAB( I)+ ROZ* SALP( I))
  4121.       EL= PI* SI( I)
  4122.       SILL= OMEGA* EL
  4123.       TOP= EL+ SILL
  4124.       BOT= EL- SILL
  4125.       IF( ABS( OMEGA).LT.1.D-7) GOTO 5
  4126.       A=2.* SIN( SILL)/ OMEGA
  4127.       GOTO 6
  4128.     5 A=(2.- OMEGA* OMEGA* EL* EL/3.)* EL
  4129.     6 IF( ABS( TOP).LT.1.D-7) GOTO 7
  4130.       TOO= SIN( TOP)/ TOP
  4131.       GOTO 8
  4132.     7 TOO=1.- TOP* TOP/6.
  4133.     8 IF( ABS( BOT).LT.1.D-7) GOTO 9
  4134.       BOO= SIN( BOT)/ BOT
  4135.       GOTO 10
  4136.     9 BOO=1.- BOT* BOT/6.
  4137.    10 B= EL*( BOO- TOO)
  4138.       C= EL*( BOO+ TOO)
  4139.       RR= A* AIR( I)+ B* BII( I)+ C* CIR( I)
  4140.       RI= A* AII( I)- B* BIR( I)+ C* CII( I)
  4141.       ARG= TP*( X( I)* ROX+ Y( I)* ROY+ Z( I)* ROZ)
  4142.       IF( K.EQ.2.AND. IFAR.GE.2) GOTO 11
  4143. C                                                                       
  4144. C     SUMMATION FOR FAR FIELD INTEGRAL                                  
  4145. C                                                                       
  4146.       EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI)
  4147.       CIX= CIX+ EXA* CAB( I)
  4148.       CIY= CIY+ EXA* SAB( I)
  4149.       CIZ= CIZ+ EXA* SALP( I)
  4150. C                                                                       
  4151. C     CALCULATION OF IMAGE CONTRIBUTION IN CLIFF AND GROUND SCREEN      
  4152. C     PROBLEMS.                                                         
  4153. C                                                                       
  4154.       GOTO 17
  4155. C                                                                       
  4156. C     SPECULAR POINT DISTANCE                                           
  4157. C                                                                       
  4158.    11 DR= Z( I)* TTHET
  4159.       D= DR* PHY+ X( I)
  4160.       IF( IFAR.EQ.2) GOTO 13
  4161.       D= SQRT( D* D+( Y( I)- DR* PHX)**2)
  4162.       IF( IFAR.EQ.3) GOTO 13
  4163. C                                                                       
  4164. C     RADIAL WIRE GROUND SCREEN REFLECTION COEFFICIENT                  
  4165. C                                                                       
  4166.       IF(( SCRWL- D).LT.0.) GOTO 12
  4167.       D= D+ T2
  4168.       ZSCRN= T1* D* LOG( D/ T2)
  4169.       ZSCRN=( ZSCRN* ZRATI)/( ETA* ZRATI+ ZSCRN)
  4170.       ZRSIN= SQRT(1.- ZSCRN* ZSCRN* THZ* THZ)
  4171.       RRV=( ROZ+ ZSCRN* ZRSIN)/(- ROZ+ ZSCRN* ZRSIN)
  4172.       RRH=( ZSCRN* ROZ+ ZRSIN)/( ZSCRN* ROZ- ZRSIN)
  4173.       GOTO 16
  4174.    12 IF( IFAR.EQ.4) GOTO 14
  4175.       IF( IFAR.EQ.5) D= DR* PHY+ X( I)
  4176.    13 IF(( CL- D).LE.0.) GOTO 15
  4177.    14 RRV= RRV1
  4178.       RRH= RRH1
  4179.       GOTO 16
  4180.    15 RRV= RRV2
  4181.       RRH= RRH2
  4182.       ARG= ARG+ DARG
  4183. C                                                                       
  4184. C     CONTRIBUTION OF EACH IMAGE SEGMENT MODIFIED BY REFLECTION COEF. , 
  4185. C     FOR CLIFF AND GROUND SCREEN PROBLEMS                              
  4186. C                                                                       
  4187.    16 EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI)
  4188.       TIX= EXA* CAB( I)
  4189.       TIY= EXA* SAB( I)
  4190.       TIZ= EXA* SALP( I)
  4191.       CDP=( TIX* PHX+ TIY* PHY)*( RRH- RRV)
  4192.       CIX= CIX+ TIX* RRV+ CDP* PHX
  4193.       CIY= CIY+ TIY* RRV+ CDP* PHY
  4194.       CIZ= CIZ- TIZ* RRV
  4195.    17 CONTINUE
  4196.       IF( K.EQ.1) GOTO 19
  4197. C                                                                       
  4198. C     CALCULATION OF CONTRIBUTION OF STRUCTURE IMAGE FOR INFINITE GROUND
  4199. C                                                                       
  4200.       IF( IFAR.GE.2) GOTO 18
  4201.       CDP=( CIX* PHX+ CIY* PHY)*( RRH- RRV)
  4202.       CIX= CCX+ CIX* RRV+ CDP* PHX
  4203.       CIY= CCY+ CIY* RRV+ CDP* PHY
  4204.       CIZ= CCZ- CIZ* RRV
  4205.       GOTO 19
  4206.    18 CIX= CIX+ CCX
  4207.       CIY= CIY+ CCY
  4208.       CIZ= CIZ+ CCZ
  4209.    19 CONTINUE
  4210.       IF( M.GT.0) GOTO 21
  4211.       ETH=( CIX* THX+ CIY* THY+ CIZ* THZ)* CONST
  4212.       EPH=( CIX* PHX+ CIY* PHY)* CONST
  4213.       RETURN
  4214.    20 CIX=(0.,0.)
  4215.       CIY=(0.,0.)
  4216.       CIZ=(0.,0.)
  4217. C                                                                       
  4218. C     ELECTRIC FIELD COMPONENTS                                         
  4219. C                                                                       
  4220.    21 ROZ= ROZS
  4221.       RFL=-1.
  4222.       DO 25  IP=1, KSYMP
  4223.       RFL=- RFL
  4224.       RRZ= ROZ* RFL
  4225.       CALL FFLDS( ROX, ROY, RRZ, CUR( N+1), GX, GY, GZ)
  4226.       IF( IP.EQ.2) GOTO 22
  4227.       EX= GX
  4228.       EY= GY
  4229.       EZ= GZ
  4230.       GOTO 25
  4231.    22 IF( IPERF.NE.1) GOTO 23
  4232.       GX=- GX
  4233.       GY=- GY
  4234.       GZ=- GZ
  4235.       GOTO 24
  4236.    23 RRV= SQRT(1.- ZRATI* ZRATI* THZ* THZ)
  4237.       RRH= ZRATI* ROZ
  4238.       RRH=( RRH- RRV)/( RRH+ RRV)
  4239.       RRV= ZRATI* RRV
  4240.       RRV=-( ROZ- RRV)/( ROZ+ RRV)
  4241.       ETH=( GX* PHX+ GY* PHY)*( RRH- RRV)
  4242.       GX= GX* RRV+ ETH* PHX
  4243.       GY= GY* RRV+ ETH* PHY
  4244.       GZ= GZ* RRV
  4245.    24 EX= EX+ GX
  4246.       EY= EY+ GY
  4247.       EZ= EZ- GZ
  4248.    25 CONTINUE
  4249.       EX= EX+ CIX* CONST
  4250.       EY= EY+ CIY* CONST
  4251.       EZ= EZ+ CIZ* CONST
  4252.       ETH= EX* THX+ EY* THY+ EZ* THZ
  4253.       EPH= EX* PHX+ EY* PHY
  4254.       RETURN
  4255.       END
  4256. C ***
  4257. C     DOUBLE PRECISION 6/4/85
  4258. C
  4259.       SUBROUTINE FFLDS( ROX, ROY, ROZ, SCUR, EX, EY, EZ)
  4260. C ***
  4261. C     CALCULATES THE XYZ COMPONENTS OF THE ELECTRIC FIELD DUE TO        
  4262. C     SURFACE CURRENTS                                                  
  4263.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  4264.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  4265.       COMPLEX  CT, CONS, SCUR, EX, EY, EZ
  4266.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  4267.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  4268.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  4269.       DIMENSION  XS(1), YS(1), ZS(1), S(1), SCUR(1), CONSX(2)
  4270.       EQUIVALENCE(XS,X),(YS,Y),(ZS,Z),(S,BI),(CONS,CONSX)
  4271.       DATA   TPI/6.283185308D+0/, CONSX/0.,188.365/
  4272.       EX=(0.,0.)
  4273.       EY=(0.,0.)
  4274.       EZ=(0.,0.)
  4275.       I= LD+1
  4276.       DO 1  J=1, M
  4277.       I= I-1
  4278.       ARG= TPI*( ROX* XS( I)+ ROY* YS( I)+ ROZ* ZS( I))
  4279.       CT= CMPLX( COS( ARG)* S( I), SIN( ARG)* S( I))
  4280.       K=3* J
  4281.       EX= EX+ SCUR( K-2)* CT
  4282.       EY= EY+ SCUR( K-1)* CT
  4283.       EZ= EZ+ SCUR( K)* CT
  4284.     1 CONTINUE
  4285.       CT= ROX* EX+ ROY* EY+ ROZ* EZ
  4286.       EX= CONS*( CT* ROX- EX)
  4287.       EY= CONS*( CT* ROY- EY)
  4288.       EZ= CONS*( CT* ROZ- EZ)
  4289.       RETURN
  4290.       END
  4291. C ***
  4292. C     DOUBLE PRECISION 6/4/85
  4293. C
  4294.       SUBROUTINE GF( ZK, CO, SI)
  4295. C ***
  4296. C                                                                       
  4297. C     GF COMPUTES THE INTEGRAND EXP(JKR)/(KR) FOR NUMERICAL INTEGRATION.
  4298. C                                                                       
  4299.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  4300.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  4301.       COMMON  /TMI/ ZPK, RKB2, IJ
  4302.       ZDK= ZK- ZPK
  4303.       RK= SQRT( RKB2+ ZDK* ZDK)
  4304.       SI= SIN( RK)/ RK
  4305.       IF( IJ) 1,2,1
  4306.     1 CO= COS( RK)/ RK
  4307.       RETURN
  4308.     2 IF( RK.LT..2) GOTO 3
  4309.       CO=( COS( RK)-1.)/ RK
  4310.       RETURN
  4311.     3 RKS= RK* RK
  4312.       CO=((-1.38888889D-3* RKS+4.16666667D-2)* RKS-.5)* RK
  4313.       RETURN
  4314.       END
  4315. C ***
  4316. C     DOUBLE PRECISION 6/4/85
  4317. C
  4318.       SUBROUTINE GFIL( IPRT)
  4319. C ***
  4320. C                                                                       
  4321. C     GFIL READS THE N.G.F. FILE                                        
  4322. C                                                                       
  4323.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  4324.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  4325.       COMPLEX  CM, SSX, ZRATI, ZRATI2, T1, ZARRAY, AR1, AR2, AR3, 
  4326.      &EPSCF, FRATI
  4327.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  4328.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  4329.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  4330.       COMMON  /CMB/ CM(90000)
  4331.       COMMON  /ANGL/ SALP( NM)
  4332.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  4333.      &KSYMP, IFAR, IPERF, T1, T2
  4334.       COMMON  /GGRID/ AR1(11,10,4), AR2(17,5,4), AR3(9,8,4), EPSCF, DXA
  4335.      &(3), DYA(3), XSA(3), YSA(3), NXA(3), NYA(3)
  4336.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  4337.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  4338.       COMMON  /SMAT/ SSX(16,16)
  4339.       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
  4340.       COMMON  /SAVE/COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(N2M),KCOM
  4341.       DATA   IGFL/20/
  4342.       REWIND IGFL
  4343.       READ( IGFL)  N1, NP, M1, MP, WLAM, FMHZ, IPSYM, KSYMP, IPERF, 
  4344.      &NRADL, EPSR, SIG, SCRWLT, SCRWRT, NLODF, KCOM
  4345.       N= N1
  4346.       M= M1
  4347.       N2= N1+1
  4348.       M2= M1+1
  4349. C     READ SEG. DATA AND CONVERT BACK TO END COORD. IN UNITS OF METERS  
  4350.       IF( N1.EQ.0) GOTO 2
  4351.       READ( IGFL) ( X( I), I=1, N1),( Y( I), I=1, N1),( Z( I), I=1, N1)
  4352.      &
  4353.       READ( IGFL) ( SI( I), I=1, N1),( BI( I), I=1, N1),( ALP( I), I=1,
  4354.      & N1)
  4355.       READ( IGFL) ( BET( I), I=1, N1),( SALP( I), I=1, N1)
  4356.       READ( IGFL) ( ICON1( I), I=1, N1),( ICON2( I), I=1, N1)
  4357.       READ( IGFL) ( ITAG( I), I=1, N1)
  4358.       IF( NLODF.NE.0) READ( IGFL) ( ZARRAY( I), I=1, N1)
  4359.       DO 1  I=1, N1
  4360.       XI= X( I)* WLAM
  4361.       YI= Y( I)* WLAM
  4362.       ZI= Z( I)* WLAM
  4363.       DX= SI( I)*.5* WLAM
  4364.       X( I)= XI- ALP( I)* DX
  4365.       Y( I)= YI- BET( I)* DX
  4366.       Z( I)= ZI- SALP( I)* DX
  4367.       SI( I)= XI+ ALP( I)* DX
  4368.       ALP( I)= YI+ BET( I)* DX
  4369.       BET( I)= ZI+ SALP( I)* DX
  4370.       BI( I)= BI( I)* WLAM
  4371.     1 CONTINUE
  4372.     2 IF( M1.EQ.0) GOTO 4
  4373. C     READ PATCH DATA AND CONVERT TO METERS                             
  4374.       J= LD- M1+1
  4375.       READ( IGFL) ( X( I), I= J, LD),( Y( I), I= J, LD),( Z( I), I= J, 
  4376.      &LD)
  4377.       READ( IGFL) ( SI( I), I= J, LD),( BI( I), I= J, LD),( ALP( I), I=
  4378.      & J, LD)
  4379.       READ( IGFL) ( BET( I), I= J, LD),( SALP( I), I= J, LD)
  4380.       READ( IGFL) ( ICON1( I), I= J, LD),( ICON2( I), I= J, LD)
  4381.       READ( IGFL) ( ITAG( I), I= J, LD)
  4382.       DX= WLAM* WLAM
  4383.       DO 3  I= J, LD
  4384.       X( I)= X( I)* WLAM
  4385.       Y( I)= Y( I)* WLAM
  4386.       Z( I)= Z( I)* WLAM
  4387.     3 BI( I)= BI( I)* DX
  4388.     4 READ( IGFL)  ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, NLSYM, 
  4389.      &IMAT
  4390.       IF( IPERF.EQ.2) READ( IGFL)  AR1, AR2, AR3, EPSCF, DXA, DYA, XSA,
  4391.      & YSA, NXA, NYA
  4392.       NEQ= N1+2* M1
  4393.       NPEQ= NP+2* MP
  4394.       NOP= NEQ/ NPEQ
  4395.       IF( NOP.GT.1) READ( IGFL) (( SSX( I, J), I=1, NOP), J=1, NOP)
  4396. C     READ MATRIX A AND WRITE TAPE13 FOR OUT OF CORE                    
  4397.       READ( IGFL) ( IP( I), I=1, NEQ), COM
  4398.       IF( ICASE.GT.2) GOTO 5
  4399.       IOUT= NEQ* NPEQ
  4400.       READ( IGFL) ( CM( I), I=1, IOUT)
  4401.       GOTO 10
  4402.     5 REWIND 13
  4403.       IF( ICASE.NE.4) GOTO 7
  4404.       IOUT= NPEQ* NPEQ
  4405.       DO 6  K=1, NOP
  4406.       READ( IGFL) ( CM( J), J=1, IOUT)
  4407.     6 WRITE( 13) ( CM( J), J=1, IOUT)
  4408.       GOTO 9
  4409.     7 IOUT= NPSYM* NPEQ*2
  4410.       NBL2=2* NBLSYM
  4411.       DO 8  IOP=1, NOP
  4412.       DO 8  I=1, NBL2
  4413.       CALL BLCKIN( CM, IGFL,1, IOUT,1,206)
  4414.     8 CALL BLCKOT( CM,13,1, IOUT,1,205)
  4415.     9 REWIND 13
  4416. C     WRITE(6,N) G.F. HEADING                                           
  4417.    10 REWIND IGFL
  4418.       WRITE( 6,16) 
  4419.       WRITE( 6,14) 
  4420.       WRITE( 6,14) 
  4421.       WRITE( 6,17) 
  4422.       WRITE( 6,18)  N1, M1
  4423.       IF( NOP.GT.1) WRITE( 6,19)  NOP
  4424.       WRITE( 6,20)  IMAT, ICASE
  4425.       IF( ICASE.LT.3) GOTO 11
  4426.       NBL2= NEQ* NPEQ
  4427.       WRITE( 6,21)  NBL2
  4428.    11 WRITE( 6,22)  FMHZ
  4429.       IF( KSYMP.EQ.2.AND. IPERF.EQ.1) WRITE( 6,23) 
  4430.       IF( KSYMP.EQ.2.AND. IPERF.EQ.0) WRITE( 6,27) 
  4431.       IF( KSYMP.EQ.2.AND. IPERF.EQ.2) WRITE( 6,28) 
  4432.       IF( KSYMP.EQ.2.AND. IPERF.NE.1) WRITE( 6,24)  EPSR, SIG
  4433.       WRITE( 6,17) 
  4434.       DO 12  J=1, KCOM
  4435.    12 WRITE( 6,15) ( COM( I, J), I=1,19)
  4436.       WRITE( 6,17) 
  4437.       WRITE( 6,14) 
  4438.       WRITE( 6,14) 
  4439.       WRITE( 6,16) 
  4440.       IF( IPRT.EQ.0) RETURN
  4441.       WRITE( 6,25) 
  4442.       DO 13  I=1, N1
  4443.    13 WRITE( 6,26)  I, X( I), Y( I), Z( I), SI( I), ALP( I), BET( I)
  4444. C                                                                       
  4445.       RETURN
  4446.    14 FORMAT(5X,'**************************************************',
  4447.      &'**********************************')
  4448.    15 FORMAT(5X,3H** ,19A4,3H **)
  4449.    16 FORMAT(////)
  4450.    17 FORMAT(5X,2H**,80X,2H**)
  4451.    18 FORMAT(5X,'** NUMERICAL GREEN S FUNCTION',53X,2H**,/,5X,'** NO',
  4452.      &'. SEGMENTS =',I4,10X,'NO. PATCHES =',I4,34X,2H**)
  4453.    19 FORMAT(5X,'** NO. SYMMETRIC SECTIONS =',I4,51X,2H**)
  4454.    20 FORMAT(5X,'** N.G.F. MATRIX -  CORE STORAGE =',I7,' COMPLEX NU',
  4455.      &'MBERS,  CASE',I2,16X,2H**)
  4456.    21 FORMAT(5X,2H**,19X,'MATRIX SIZE =',I7,' COMPLEX NUMBERS',25X,'**')
  4457.    22 FORMAT(5X,'** FREQUENCY =',1P,E12.5,' MHZ.',51X,2H**)
  4458.    23 FORMAT(5X,'** PERFECT GROUND',65X,2H**)
  4459.    24 FORMAT(5X,'** GROUND PARAMETERS - DIELECTRIC CONSTANT =',1P,E12.5,
  4460.      &26X,'**',/,5X,'**',21X,'CONDUCTIVITY =',E12.5,' MHOS/M.',25X,'**')
  4461.    25 FORMAT(39X,'NUMERICAL GREEN S FUNCTION DATA',/,41X,'COORDINATES',
  4462.      &' OF SEGMENT ENDS',/,51X,'(METERS)',/,5X,'SEG.',11X,
  4463.      &'- - - END ON''E - - -',26X,'- - - END TWO - - -',/,6X,3HNO.,6X,1
  4464.      &HX,14X,1HY,14X,1HZ,14X,1HX,14X,1HY,14X,1HZ)
  4465.    26 FORMAT(1X,I7,1P,6E15.6)
  4466.    27 FORMAT(5X,'** FINITE GROUND.  REFLECTION COEFFICIENT APPROXIMAT',
  4467.      &'ION',27X,2H**)
  4468.    28 FORMAT(5X,'** FINITE GROUND.  SOMMERFELD SOLUTION',44X,'**')
  4469.       END
  4470. C ***
  4471. C     DOUBLE PRECISION 6/4/85
  4472. C
  4473.       SUBROUTINE GFLD( RHO, PHI, RZ, ETH, EPI, ERD, UX, KSYMP)
  4474. C ***
  4475. C                                                                       
  4476. C     GFLD COMPUTES THE RADIATED FIELD INCLUDING GROUND WAVE.           
  4477. C                                                                       
  4478.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  4479.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  4480.       COMPLEX  CUR, EPI, CIX, CIY, CIZ, EXA, XX1, XX2, U, U2, ERV, 
  4481.      &EZV, ERH, EPH
  4482.       COMPLEX  EZH, EX, EY, ETH, UX, ERD
  4483.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  4484.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  4485.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  4486.       COMMON  /ANGL/ SALP( NM)
  4487.       COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM), 
  4488.      &CII( NM), CUR( N3M)
  4489.       COMMON  /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
  4490.       DIMENSION  CAB(1), SAB(1)
  4491.       EQUIVALENCE(CAB(1),ALP(1)),(SAB(1),BET(1))
  4492.       DATA   PI, TP/3.141592654D+0,6.283185308D+0/
  4493.       R= SQRT( RHO* RHO+ RZ* RZ)
  4494.       IF( KSYMP.EQ.1) GOTO 1
  4495.       IF( ABS( UX).GT..5) GOTO 1
  4496.       IF( R.GT.1.E5) GOTO 1
  4497. C                                                                       
  4498. C     COMPUTATION OF SPACE WAVE ONLY                                    
  4499. C                                                                       
  4500.       GOTO 4
  4501.     1 IF( RZ.LT.1.D-20) GOTO 2
  4502.       THET= ATAN( RHO/ RZ)
  4503.       GOTO 3
  4504.     2 THET= PI*.5
  4505.     3 CALL FFLD( THET, PHI, ETH, EPI)
  4506.       ARG=- TP* R
  4507.       EXA= CMPLX( COS( ARG), SIN( ARG))/ R
  4508.       ETH= ETH* EXA
  4509.       EPI= EPI* EXA
  4510.       ERD=(0.,0.)
  4511. C                                                                       
  4512. C     COMPUTATION OF SPACE AND GROUND WAVES.                            
  4513. C                                                                       
  4514.       RETURN
  4515.     4 U= UX
  4516.       U2= U* U
  4517.       PHX=- SIN( PHI)
  4518.       PHY= COS( PHI)
  4519.       RX= RHO* PHY
  4520.       RY=- RHO* PHX
  4521.       CIX=(0.,0.)
  4522.       CIY=(0.,0.)
  4523. C                                                                       
  4524. C     SUMMATION OF FIELD FROM INDIVIDUAL SEGMENTS                       
  4525. C                                                                       
  4526.       CIZ=(0.,0.)
  4527.       DO 17  I=1, N
  4528.       DX= CAB( I)
  4529.       DY= SAB( I)
  4530.       DZ= SALP( I)
  4531.       RIX= RX- X( I)
  4532.       RIY= RY- Y( I)
  4533.       RHS= RIX* RIX+ RIY* RIY
  4534.       RHP= SQRT( RHS)
  4535.       IF( RHP.LT.1.D-6) GOTO 5
  4536.       RHX= RIX/ RHP
  4537.       RHY= RIY/ RHP
  4538.       GOTO 6
  4539.     5 RHX=1.
  4540.       RHY=0.
  4541.     6 CALP=1.- DZ* DZ
  4542.       IF( CALP.LT.1.D-6) GOTO 7
  4543.       CALP= SQRT( CALP)
  4544.       CBET= DX/ CALP
  4545.       SBET= DY/ CALP
  4546.       CPH= RHX* CBET+ RHY* SBET
  4547.       SPH= RHY* CBET- RHX* SBET
  4548.       GOTO 8
  4549.     7 CPH= RHX
  4550.       SPH= RHY
  4551.     8 EL= PI* SI( I)
  4552. C                                                                       
  4553. C     INTEGRATION OF (CURRENT)*(PHASE FACTOR) OVER SEGMENT AND IMAGE FOR
  4554. C     CONSTANT, SINE, AND COSINE CURRENT DISTRIBUTIONS                  
  4555. C                                                                       
  4556.       RFL=-1.
  4557.       DO 16  K=1,2
  4558.       RFL=- RFL
  4559.       RIZ= RZ- Z( I)* RFL
  4560.       RXYZ= SQRT( RIX* RIX+ RIY* RIY+ RIZ* RIZ)
  4561.       RNX= RIX/ RXYZ
  4562.       RNY= RIY/ RXYZ
  4563.       RNZ= RIZ/ RXYZ
  4564.       OMEGA=-( RNX* DX+ RNY* DY+ RNZ* DZ* RFL)
  4565.       SILL= OMEGA* EL
  4566.       TOP= EL+ SILL
  4567.       BOT= EL- SILL
  4568.       IF( ABS( OMEGA).LT.1.D-7) GOTO 9
  4569.       A=2.* SIN( SILL)/ OMEGA
  4570.       GOTO 10
  4571.     9 A=(2.- OMEGA* OMEGA* EL* EL/3.)* EL
  4572.    10 IF( ABS( TOP).LT.1.D-7) GOTO 11
  4573.       TOO= SIN( TOP)/ TOP
  4574.       GOTO 12
  4575.    11 TOO=1.- TOP* TOP/6.
  4576.    12 IF( ABS( BOT).LT.1.D-7) GOTO 13
  4577.       BOO= SIN( BOT)/ BOT
  4578.       GOTO 14
  4579.    13 BOO=1.- BOT* BOT/6.
  4580.    14 B= EL*( BOO- TOO)
  4581.       C= EL*( BOO+ TOO)
  4582.       RR= A* AIR( I)+ B* BII( I)+ C* CIR( I)
  4583.       RI= A* AII( I)- B* BIR( I)+ C* CII( I)
  4584.       ARG= TP*( X( I)* RNX+ Y( I)* RNY+ Z( I)* RNZ* RFL)
  4585.       EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI)/ TP
  4586.       IF( K.EQ.2) GOTO 15
  4587.       XX1= EXA
  4588.       R1= RXYZ
  4589.       ZMH= RIZ
  4590.       GOTO 16
  4591.    15 XX2= EXA
  4592.       R2= RXYZ
  4593.       ZPH= RIZ
  4594. C                                                                       
  4595. C     CALL SUBROUTINE TO COMPUTE THE FIELD OF SEGMENT INCLUDING GROUND  
  4596. C     WAVE.                                                             
  4597. C                                                                       
  4598.    16 CONTINUE
  4599.       CALL GWAVE( ERV, EZV, ERH, EZH, EPH)
  4600.       ERH= ERH* CPH* CALP+ ERV* DZ
  4601.       EPH= EPH* SPH* CALP
  4602.       EZH= EZH* CPH* CALP+ EZV* DZ
  4603.       EX= ERH* RHX- EPH* RHY
  4604.       EY= ERH* RHY+ EPH* RHX
  4605.       CIX= CIX+ EX
  4606.       CIY= CIY+ EY
  4607.    17 CIZ= CIZ+ EZH
  4608.       ARG=- TP* R
  4609.       EXA= CMPLX( COS( ARG), SIN( ARG))
  4610.       CIX= CIX* EXA
  4611.       CIY= CIY* EXA
  4612.       CIZ= CIZ* EXA
  4613.       RNX= RX/ R
  4614.       RNY= RY/ R
  4615.       RNZ= RZ/ R
  4616.       THX= RNZ* PHY
  4617.       THY=- RNZ* PHX
  4618.       THZ=- RHO/ R
  4619.       ETH= CIX* THX+ CIY* THY+ CIZ* THZ
  4620.       EPI= CIX* PHX+ CIY* PHY
  4621.       ERD= CIX* RNX+ CIY* RNY+ CIZ* RNZ
  4622.       RETURN
  4623.       END
  4624. C ***
  4625. C     DOUBLE PRECISION 6/4/85
  4626. C
  4627.       SUBROUTINE GFOUT
  4628. C ***
  4629. C                                                                       
  4630. C     WRITE N.G.F. FILE                                                 
  4631. C                                                                       
  4632.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  4633.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  4634.       COMPLEX  CM, SSX, ZRATI, ZRATI2, T1, ZARRAY, AR1, AR2, AR3, 
  4635.      &EPSCF, FRATI
  4636.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  4637.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  4638.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  4639.       COMMON  /CMB/ CM(90000)
  4640.       COMMON  /ANGL/ SALP( NM)
  4641.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  4642.      &KSYMP, IFAR, IPERF, T1, T2
  4643.       COMMON  /GGRID/ AR1(11,10,4), AR2(17,5,4), AR3(9,8,4), EPSCF, DXA
  4644.      &(3), DYA(3), XSA(3), YSA(3), NXA(3), NYA(3)
  4645.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  4646.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  4647.       COMMON  /SMAT/ SSX(16,16)
  4648.       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
  4649.       COMMON  /SAVE/COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(N2M),KCOM
  4650.       DATA   IGFL/20/
  4651.       NEQ= N+2* M
  4652.       NPEQ= NP+2* MP
  4653.       NOP= NEQ/ NPEQ
  4654.       WRITE( IGFL)  N, NP, M, MP, WLAM, FMHZ, IPSYM, KSYMP, IPERF, 
  4655.      &NRADL, EPSR, SIG, SCRWLT, SCRWRT, NLOAD, KCOM
  4656.       IF( N.EQ.0) GOTO 1
  4657.       WRITE( IGFL) ( X( I), I=1, N),( Y( I), I=1, N),( Z( I), I=1, N)
  4658.       WRITE( IGFL) ( SI( I), I=1, N),( BI( I), I=1, N),( ALP( I), I=1, 
  4659.      &N)
  4660.       WRITE( IGFL) ( BET( I), I=1, N),( SALP( I), I=1, N)
  4661.       WRITE( IGFL) ( ICON1( I), I=1, N),( ICON2( I), I=1, N)
  4662.       WRITE( IGFL) ( ITAG( I), I=1, N)
  4663.       IF( NLOAD.GT.0) WRITE( IGFL) ( ZARRAY( I), I=1, N)
  4664.     1 IF( M.EQ.0) GOTO 2
  4665.       J= LD- M+1
  4666.       WRITE( IGFL) ( X( I), I= J, LD),( Y( I), I= J, LD),( Z( I), I= J,
  4667.      & LD)
  4668.       WRITE( IGFL) ( SI( I), I= J, LD),( BI( I), I= J, LD),( ALP( I), I
  4669.      &= J, LD)
  4670.       WRITE( IGFL) ( BET( I), I= J, LD),( SALP( I), I= J, LD)
  4671.       WRITE( IGFL) ( ICON1( I), I= J, LD),( ICON2( I), I= J, LD)
  4672.       WRITE( IGFL) ( ITAG( I), I= J, LD)
  4673.     2 WRITE( IGFL)  ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, NLSYM, 
  4674.      &IMAT
  4675.       IF( IPERF.EQ.2) WRITE( IGFL)  AR1, AR2, AR3, EPSCF, DXA, DYA, XSA
  4676.      &, YSA, NXA, NYA
  4677.       IF( NOP.GT.1) WRITE( IGFL) (( SSX( I, J), I=1, NOP), J=1, NOP)
  4678.       WRITE( IGFL) ( IP( I), I=1, NEQ), COM
  4679.       IF( ICASE.GT.2) GOTO 3
  4680.       IOUT= NEQ* NPEQ
  4681.       WRITE( IGFL) ( CM( I), I=1, IOUT)
  4682.       GOTO 12
  4683.     3 IF( ICASE.NE.4) GOTO 5
  4684.       REWIND 13
  4685.       I= NPEQ* NPEQ
  4686.       DO 4  K=1, NOP
  4687.       READ( 13) ( CM( J), J=1, I)
  4688.     4 WRITE( IGFL) ( CM( J), J=1, I)
  4689.       REWIND 13
  4690.       GOTO 12
  4691.     5 REWIND 13
  4692.       REWIND 14
  4693.       IF( ICASE.EQ.5) GOTO 8
  4694.       IOUT= NPBLK* NEQ*2
  4695.       DO 6  I=1, NBLOKS
  4696.       CALL BLCKIN( CM,13,1, IOUT,1,201)
  4697.     6 CALL BLCKOT( CM, IGFL,1, IOUT,1,202)
  4698.       DO 7  I=1, NBLOKS
  4699.       CALL BLCKIN( CM,14,1, IOUT,1,203)
  4700.     7 CALL BLCKOT( CM, IGFL,1, IOUT,1,204)
  4701.       GOTO 12
  4702.     8 IOUT= NPSYM* NPEQ*2
  4703.       DO 11  IOP=1, NOP
  4704.       DO 9  I=1, NBLSYM
  4705.       CALL BLCKIN( CM,13,1, IOUT,1,205)
  4706.     9 CALL BLCKOT( CM, IGFL,1, IOUT,1,206)
  4707.       DO 10  I=1, NBLSYM
  4708.       CALL BLCKIN( CM,14,1, IOUT,1,207)
  4709.    10 CALL BLCKOT( CM, IGFL,1, IOUT,1,208)
  4710.    11 CONTINUE
  4711.       REWIND 13
  4712.       REWIND 14
  4713.    12 REWIND IGFL
  4714.       WRITE( 6,13)  IGFL, IMAT
  4715. C                                                                       
  4716.       RETURN
  4717.    13 FORMAT(///,' ****NUMERICAL GREEN S FUNCTION FILE ON TAPE',I3,
  4718.      &'****',/,5X,'MATRIX STORAGE -',I7,' COMPLEX NUMBERS',///)
  4719.       END
  4720. C ***
  4721. C     DOUBLE PRECISION 6/4/85
  4722. C
  4723.       SUBROUTINE GH( ZK, HR, HI)
  4724. C ***
  4725. C     INTEGRAND FOR H FIELD OF A WIRE                                   
  4726.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  4727.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  4728.       COMMON  /TMH/ ZPK, RHKS
  4729.       RS= ZK- ZPK
  4730.       RS= RHKS+ RS* RS
  4731.       R= SQRT( RS)
  4732.       CKR= COS( R)
  4733.       SKR= SIN( R)
  4734.       RR2=1./ RS
  4735.       RR3= RR2/ R
  4736.       HR= SKR* RR2+ CKR* RR3
  4737.       HI= CKR* RR2- SKR* RR3
  4738.       RETURN
  4739.       END
  4740. C ***
  4741. C     DOUBLE PRECISION 6/4/85
  4742. C
  4743.       SUBROUTINE GWAVE( ERV, EZV, ERH, EZH, EPH)
  4744. C ***
  4745. C                                                                       
  4746. C     GWAVE COMPUTES THE ELECTRIC FIELD, INCLUDING GROUND WAVE, OF A    
  4747. C     CURRENT ELEMENT OVER A GROUND PLANE USING FORMULAS OF K.A. NORTON 
  4748. C     (PROC. IRE, SEPT., 1937, PP.1203,1236.)                           
  4749. C                                                                       
  4750.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  4751.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  4752.       COMPLEX  FJ, TPJ, U2, U, RK1, RK2, T1, T2, T3, T4, P1, RV, OMR
  4753.      &, W, F, Q1, RH, V, G, XR1, XR2, X1, X2, X3, X4, X5, X6, X7, EZV, 
  4754.      &ERV, EZH, ERH, EPH, XX1, XX2, ECON, FBAR
  4755.       COMMON  /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
  4756.       DIMENSION  FJX(2), TPJX(2), ECONX(2)
  4757.       EQUIVALENCE(FJ,FJX),(TPJ,TPJX),(ECON,ECONX)
  4758.       DATA   PI/3.141592654D+0/, FJX/0.,1./, TPJX/0.,6.283185308D+0/
  4759.       DATA   ECONX/0.,-188.367/
  4760.       SPPP= ZMH/ R1
  4761.       SPPP2= SPPP* SPPP
  4762.       CPPP2=1.- SPPP2
  4763.       IF( CPPP2.LT.1.D-20) CPPP2=1.D-20
  4764.       CPPP= SQRT( CPPP2)
  4765.       SPP= ZPH/ R2
  4766.       SPP2= SPP* SPP
  4767.       CPP2=1.- SPP2
  4768.       IF( CPP2.LT.1.D-20) CPP2=1.D-20
  4769.       CPP= SQRT( CPP2)
  4770.       RK1=- TPJ* R1
  4771.       RK2=- TPJ* R2
  4772.       T1=1.- U2* CPP2
  4773.       T2= SQRT( T1)
  4774.       T3=(1.-1./ RK1)/ RK1
  4775.       T4=(1.-1./ RK2)/ RK2
  4776.       P1= RK2* U2* T1/(2.* CPP2)
  4777.       RV=( SPP- U* T2)/( SPP+ U* T2)
  4778.       OMR=1.- RV
  4779.       W=1./ OMR
  4780.       W=(4.,0.)* P1* W* W
  4781.       F= FBAR( W)
  4782.       Q1= RK2* T1/(2.* U2* CPP2)
  4783.       RH=( T2- U* SPP)/( T2+ U* SPP)
  4784.       V=1./(1.+ RH)
  4785.       V=(4.,0.)* Q1* V* V
  4786.       G= FBAR( V)
  4787.       XR1= XX1/ R1
  4788.       XR2= XX2/ R2
  4789.       X1= CPPP2* XR1
  4790.       X2= RV* CPP2* XR2
  4791.       X3= OMR* CPP2* F* XR2
  4792.       X4= U* T2* SPP*2.* XR2/ RK2
  4793.       X5= XR1* T3*(1.-3.* SPPP2)
  4794.       X6= XR2* T4*(1.-3.* SPP2)
  4795.       EZV=( X1+ X2+ X3- X4- X5- X6)* ECON
  4796.       X1= SPPP* CPPP* XR1
  4797.       X2= RV* SPP* CPP* XR2
  4798.       X3= CPP* OMR* U* T2* F* XR2
  4799.       X4= SPP* CPP* OMR* XR2/ RK2
  4800.       X5=3.* SPPP* CPPP* T3* XR1
  4801.       X6= CPP* U* T2* OMR* XR2/ RK2*.5
  4802.       X7=3.* SPP* CPP* T4* XR2
  4803.       ERV=-( X1+ X2- X3+ X4- X5+ X6- X7)* ECON
  4804.       EZH=-( X1- X2+ X3- X4- X5- X6+ X7)* ECON
  4805.       X1= SPPP2* XR1
  4806.       X2= RV* SPP2* XR2
  4807.       X4= U2* T1* OMR* F* XR2
  4808.       X5= T3*(1.-3.* CPPP2)* XR1
  4809.       X6= T4*(1.-3.* CPP2)*(1.- U2*(1.+ RV)- U2* OMR* F)* XR2
  4810.       X7= U2* CPP2* OMR*(1.-1./ RK2)*( F*( U2* T1- SPP2-1./ RK2)+1./ 
  4811.      &RK2)* XR2
  4812.       ERH=( X1- X2- X4- X5+ X6+ X7)* ECON
  4813.       X1= XR1
  4814.       X2= RH* XR2
  4815.       X3=( RH+1.)* G* XR2
  4816.       X4= T3* XR1
  4817.       X5= T4*(1.- U2*(1.+ RV)- U2* OMR* F)* XR2
  4818.       X6=.5* U2* OMR*( F*( U2* T1- SPP2-1./ RK2)+1./ RK2)* XR2/ RK2
  4819.       EPH=-( X1- X2+ X3- X4+ X5+ X6)* ECON
  4820.       RETURN
  4821.       END
  4822. C ***
  4823. C     DOUBLE PRECISION 6/4/85
  4824. C
  4825.       SUBROUTINE GX( ZZ, RH, XK, GZ, GZP)
  4826. C ***
  4827. C     SEGMENT END CONTRIBUTIONS FOR THIN WIRE APPROX.                   
  4828.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  4829.       COMPLEX  GZ, GZP
  4830.       R2= ZZ* ZZ+ RH* RH
  4831.       R= SQRT( R2)
  4832.       RKZ= XK* R
  4833.       GZ= CMPLX( COS( RKZ),- SIN( RKZ))/ R
  4834.       GZP=- CMPLX(1.0, RKZ)* GZ/ R2
  4835.       RETURN
  4836.       END
  4837. C ***
  4838. C     DOUBLE PRECISION 6/4/85
  4839. C
  4840.       SUBROUTINE GXX( ZZ, RH, A, A2, XK, IRA, G1, G1P, G2, G2P, G3, GZP
  4841.      &)
  4842. C ***
  4843. C     SEGMENT END CONTRIBUTIONS FOR EXT. THIN WIRE APPROX.              
  4844.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  4845.       COMPLEX  GZ, C1, C2, C3, G1, G1P, G2, G2P, G3, GZP
  4846.       R2= ZZ* ZZ+ RH* RH
  4847.       R= SQRT( R2)
  4848.       R4= R2* R2
  4849.       RK= XK* R
  4850.       RK2= RK* RK
  4851.       RH2= RH* RH
  4852.       T1=.25* A2* RH2/ R4
  4853.       T2=.5* A2/ R2
  4854.       C1= CMPLX(1.0, RK)
  4855.       C2=3.* C1- RK2
  4856.       C3= CMPLX(6.0, RK)* RK2-15.* C1
  4857.       GZ= CMPLX( COS( RK),- SIN( RK))/ R
  4858.       G2= GZ*(1.+ T1* C2)
  4859.       G1= G2- T2* C1* GZ
  4860.       GZ= GZ/ R2
  4861.       G2P= GZ*( T1* C3- C1)
  4862.       GZP= T2* C2* GZ
  4863.       G3= G2P+ GZP
  4864.       G1P= G3* ZZ
  4865.       IF( IRA.EQ.1) GOTO 2
  4866.       G3=( G3+ GZP)* RH
  4867.       GZP=- ZZ* C1* GZ
  4868.       IF( RH.GT.1.D-10) GOTO 1
  4869.       G2=0.
  4870.       G2P=0.
  4871.       RETURN
  4872.     1 G2= G2/ RH
  4873.       G2P= G2P* ZZ/ RH
  4874.       RETURN
  4875.     2 T2=.5* A
  4876.       G2=- T2* C1* GZ
  4877.       G2P= T2* GZ* C2/ R2
  4878.       G3= RH2* G2P- A* GZ* C1
  4879.       G2P= G2P* ZZ
  4880.       GZP=- ZZ* C1* GZ
  4881.       RETURN
  4882.       END
  4883. C ***
  4884. C     DOUBLE PRECISION 6/4/85
  4885. C
  4886.       SUBROUTINE HELIX( S, HL, A1, B1, A2, B2, RAD, NS, ITG)
  4887. C ***
  4888. C     SUBROUTINE HELIX GENERATES SEGMENT GEOMETRY DATA FOR A HELIX OF NS
  4889. C     SEGMENTS
  4890.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  4891.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  4892.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  4893.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  4894.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  4895.       DIMENSION  X2(1), Y2(1), Z2(1)
  4896.       EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1))
  4897.       DATA   PI/3.1415926D+0/
  4898.       IST= N+1
  4899.       N= N+ NS
  4900.       NP= N
  4901.       MP= M
  4902.       IPSYM=0
  4903.       IF( NS.LT.1) RETURN
  4904.       TURNS= ABS( HL/ S)
  4905.       ZINC= ABS( HL/ NS)
  4906.       Z( IST)=0.
  4907.       DO 25  I= IST, N
  4908.       BI( I)= RAD
  4909.       ITAG( I)= ITG
  4910.       IF( I.NE. IST) Z( I)= Z( I-1)+ ZINC
  4911.       Z2( I)= Z( I)+ ZINC
  4912.       IF( A2.NE. A1) GOTO 10
  4913.       IF( B1.EQ.0) B1= A1
  4914.       X( I)= A1* COS(2.* PI* Z( I)/ S)
  4915.       Y( I)= B1* SIN(2.* PI* Z( I)/ S)
  4916.       X2( I)= A1* COS(2.* PI* Z2( I)/ S)
  4917.       Y2( I)= B1* SIN(2.* PI* Z2( I)/ S)
  4918.       GOTO 20
  4919.    10 IF( B2.EQ.0) B2= A2
  4920.       X( I)=( A1+( A2- A1)* Z( I)/ ABS( HL))* COS(2.* PI* Z( I)/ S)
  4921.       Y( I)=( B1+( B2- B1)* Z( I)/ ABS( HL))* SIN(2.* PI* Z( I)/ S)
  4922.       X2( I)=( A1+( A2- A1)* Z2( I)/ ABS( HL))* COS(2.* PI* Z2( I)/ S)
  4923.       Y2( I)=( B1+( B2- B1)* Z2( I)/ ABS( HL))* SIN(2.* PI* Z2( I)/ S)
  4924.    20 IF( HL.GT.0) GOTO 25
  4925.       COPY= X( I)
  4926.       X( I)= Y( I)
  4927.       Y( I)= COPY
  4928.       COPY= X2( I)
  4929.       X2( I)= Y2( I)
  4930.       Y2( I)= COPY
  4931.    25 CONTINUE
  4932.       IF( A2.EQ. A1) GOTO 21
  4933.       SANGLE= ATAN( A2/( ABS( HL)+( ABS( HL)* A1)/( A2- A1)))
  4934.       WRITE( 6,104)  SANGLE
  4935.   104 FORMAT(5X,'THE CONE ANGLE OF THE SPIRAL IS',F10.4)
  4936.       RETURN
  4937.    21 IF( A1.NE. B1) GOTO 30
  4938.       HDIA=2.* A1
  4939.       TURN= HDIA* PI
  4940.       PITCH= ATAN( S/( PI* HDIA))
  4941.       TURN= TURN/ COS( PITCH)
  4942.       PITCH=180.* PITCH/ PI
  4943.       GOTO 40
  4944.    30 IF( A1.LT. B1) GOTO 34
  4945.       HMAJ=2.* A1
  4946.       HMIN=2.* B1
  4947.       GOTO 35
  4948.    34 HMAJ=2.* B1
  4949.       HMIN=2.* A1
  4950.    35 HDIA= SQRT(( HMAJ**2+ HMIN**2)/2* HMAJ)
  4951.       TURN=2.* PI* HDIA
  4952.       PITCH=(180./ PI)* ATAN( S/( PI* HDIA))
  4953.    40 WRITE( 6,105)  PITCH, TURN
  4954.   105 FORMAT(5X,'THE PITCH ANGLE IS',F10.4/5X,
  4955.      &'THE LENGTH OF WIRE/TURN ''IS',F10.4)
  4956.       RETURN
  4957.       END
  4958. C ***
  4959. C     DOUBLE PRECISION 6/4/85
  4960. C
  4961.       SUBROUTINE HFK( EL1, EL2, RHK, ZPKX, SGR, SGI)
  4962. C ***
  4963. C     HFK COMPUTES THE H FIELD OF A UNIFORM CURRENT FILAMENT BY         
  4964. C     NUMERICAL INTEGRATION                                             
  4965.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  4966.       COMMON  /TMH/ ZPK, RHKS
  4967.       DATA   NX, NM, NTS, RX/1,65536,4,1.D-4/
  4968.       ZPK= ZPKX
  4969.       RHKS= RHK* RHK
  4970.       Z= EL1
  4971.       ZE= EL2
  4972.       S= ZE- Z
  4973.       EP= S/(10.* NM)
  4974.       ZEND= ZE- EP
  4975.       SGR=0.0
  4976.       SGI=0.0
  4977.       NS= NX
  4978.       NT=0
  4979.       CALL GH( Z, G1R, G1I)
  4980.     1 DZ= S/ NS
  4981.       ZP= Z+ DZ
  4982.       IF( ZP- ZE) 3,3,2
  4983.     2 DZ= ZE- Z
  4984.       IF( ABS( DZ)- EP) 17,17,3
  4985.     3 DZOT= DZ*.5
  4986.       ZP= Z+ DZOT
  4987.       CALL GH( ZP, G3R, G3I)
  4988.       ZP= Z+ DZ
  4989.       CALL GH( ZP, G5R, G5I)
  4990.     4 T00R=( G1R+ G5R)* DZOT
  4991.       T00I=( G1I+ G5I)* DZOT
  4992.       T01R=( T00R+ DZ* G3R)*0.5
  4993.       T01I=( T00I+ DZ* G3I)*0.5
  4994.       T10R=(4.0* T01R- T00R)/3.0
  4995.       T10I=(4.0* T01I- T00I)/3.0
  4996.       CALL TEST( T01R, T10R, TE1R, T01I, T10I, TE1I,0.)
  4997.       IF( TE1I- RX) 5,5,6
  4998.     5 IF( TE1R- RX) 8,8,6
  4999.     6 ZP= Z+ DZ*0.25
  5000.       CALL GH( ZP, G2R, G2I)
  5001.       ZP= Z+ DZ*0.75
  5002.       CALL GH( ZP, G4R, G4I)
  5003.       T02R=( T01R+ DZOT*( G2R+ G4R))*0.5
  5004.       T02I=( T01I+ DZOT*( G2I+ G4I))*0.5
  5005.       T11R=(4.0* T02R- T01R)/3.0
  5006.       T11I=(4.0* T02I- T01I)/3.0
  5007.       T20R=(16.0* T11R- T10R)/15.0
  5008.       T20I=(16.0* T11I- T10I)/15.0
  5009.       CALL TEST( T11R, T20R, TE2R, T11I, T20I, TE2I,0.)
  5010.       IF( TE2I- RX) 7,7,14
  5011.     7 IF( TE2R- RX) 9,9,14
  5012.     8 SGR= SGR+ T10R
  5013.       SGI= SGI+ T10I
  5014.       NT= NT+2
  5015.       GOTO 10
  5016.     9 SGR= SGR+ T20R
  5017.       SGI= SGI+ T20I
  5018.       NT= NT+1
  5019.    10 Z= Z+ DZ
  5020.       IF( Z- ZEND) 11,17,17
  5021.    11 G1R= G5R
  5022.       G1I= G5I
  5023.       IF( NT- NTS) 1,12,12
  5024.    12 IF( NS- NX) 1,1,13
  5025.    13 NS= NS/2
  5026.       NT=1
  5027.       GOTO 1
  5028.    14 NT=0
  5029.       IF( NS- NM) 16,15,15
  5030.    15 WRITE( 6,18)  Z
  5031.       GOTO 9
  5032.    16 NS= NS*2
  5033.       DZ= S/ NS
  5034.       DZOT= DZ*0.5
  5035.       G5R= G3R
  5036.       G5I= G3I
  5037.       G3R= G2R
  5038.       G3I= G2I
  5039.       GOTO 4
  5040.    17 CONTINUE
  5041.       SGR= SGR* RHK*.5
  5042.       SGI= SGI* RHK*.5
  5043. C                                                                       
  5044.       RETURN
  5045.    18 FORMAT(' STEP SIZE LIMITED AT Z=',F10.5)
  5046.       END
  5047. C ***
  5048. C     DOUBLE PRECISION 6/4/85
  5049. C
  5050.       SUBROUTINE HINTG( XI, YI, ZI)
  5051. C ***
  5052. C     HINTG COMPUTES THE H FIELD OF A PATCH CURRENT                     
  5053.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  5054.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  5055.       COMPLEX  EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, ZRATI, 
  5056.      &ZRATI2, GAM, F1X, F1Y, F1Z, F2X, F2Y, F2Z, RRV, RRH, T1, FRATI
  5057.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  5058.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  5059.      &INDD2, IPGND
  5060.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  5061.      &KSYMP, IFAR, IPERF, T1, T2
  5062.       EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
  5063.      &IND1),(T2ZJ,IND2)
  5064.       DATA   FPI/12.56637062D+0/, TP/6.283185308D+0/
  5065.       RX= XI- XJ
  5066.       RY= YI- YJ
  5067.       RFL=-1.
  5068.       EXK=(0.,0.)
  5069.       EYK=(0.,0.)
  5070.       EZK=(0.,0.)
  5071.       EXS=(0.,0.)
  5072.       EYS=(0.,0.)
  5073.       EZS=(0.,0.)
  5074.       DO 5  IP=1, KSYMP
  5075.       RFL=- RFL
  5076.       RZ= ZI- ZJ* RFL
  5077.       RSQ= RX* RX+ RY* RY+ RZ* RZ
  5078.       IF( RSQ.LT.1.D-20) GOTO 5
  5079.       R= SQRT( RSQ)
  5080.       RK= TP* R
  5081.       CR= COS( RK)
  5082.       SR= SIN( RK)
  5083.       GAM=-( CMPLX( CR,- SR)+ RK* CMPLX( SR, CR))/( FPI* RSQ* R)* S
  5084.       EXC= GAM* RX
  5085.       EYC= GAM* RY
  5086.       EZC= GAM* RZ
  5087.       T1ZR= T1ZJ* RFL
  5088.       T2ZR= T2ZJ* RFL
  5089.       F1X= EYC* T1ZR- EZC* T1YJ
  5090.       F1Y= EZC* T1XJ- EXC* T1ZR
  5091.       F1Z= EXC* T1YJ- EYC* T1XJ
  5092.       F2X= EYC* T2ZR- EZC* T2YJ
  5093.       F2Y= EZC* T2XJ- EXC* T2ZR
  5094.       F2Z= EXC* T2YJ- EYC* T2XJ
  5095.       IF( IP.EQ.1) GOTO 4
  5096.       IF( IPERF.NE.1) GOTO 1
  5097.       F1X=- F1X
  5098.       F1Y=- F1Y
  5099.       F1Z=- F1Z
  5100.       F2X=- F2X
  5101.       F2Y=- F2Y
  5102.       F2Z=- F2Z
  5103.       GOTO 4
  5104.     1 XYMAG= SQRT( RX* RX+ RY* RY)
  5105.       IF( XYMAG.GT.1.D-6) GOTO 2
  5106.       PX=0.
  5107.       PY=0.
  5108.       CTH=1.
  5109.       RRV=(1.,0.)
  5110.       GOTO 3
  5111.     2 PX=- RY/ XYMAG
  5112.       PY= RX/ XYMAG
  5113.       CTH= RZ/ R
  5114.       RRV= SQRT(1.- ZRATI* ZRATI*(1.- CTH* CTH))
  5115.     3 RRH= ZRATI* CTH
  5116.       RRH=( RRH- RRV)/( RRH+ RRV)
  5117.       RRV= ZRATI* RRV
  5118.       RRV=-( CTH- RRV)/( CTH+ RRV)
  5119.       GAM=( F1X* PX+ F1Y* PY)*( RRV- RRH)
  5120.       F1X= F1X* RRH+ GAM* PX
  5121.       F1Y= F1Y* RRH+ GAM* PY
  5122.       F1Z= F1Z* RRH
  5123.       GAM=( F2X* PX+ F2Y* PY)*( RRV- RRH)
  5124.       F2X= F2X* RRH+ GAM* PX
  5125.       F2Y= F2Y* RRH+ GAM* PY
  5126.       F2Z= F2Z* RRH
  5127.     4 EXK= EXK+ F1X
  5128.       EYK= EYK+ F1Y
  5129.       EZK= EZK+ F1Z
  5130.       EXS= EXS+ F2X
  5131.       EYS= EYS+ F2Y
  5132.       EZS= EZS+ F2Z
  5133.     5 CONTINUE
  5134.       RETURN
  5135.       END
  5136. C ***
  5137. C     DOUBLE PRECISION 6/4/85
  5138. C
  5139.       SUBROUTINE HSFLD( XI, YI, ZI, AI)
  5140. C ***
  5141. C     HSFLD COMPUTES THE H FIELD FOR CONSTANT, SINE, AND COSINE CURRENT 
  5142. C     ON A SEGMENT INCLUDING GROUND EFFECTS.                            
  5143.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  5144.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  5145.       COMPLEX  EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, ZRATI, 
  5146.      &ZRATI2, T1, HPK, HPS, HPC, QX, QY, QZ, RRV, RRH, ZRATX, FRATI
  5147.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  5148.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  5149.      &INDD2, IPGND
  5150.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  5151.      &KSYMP, IFAR, IPERF, T1, T2
  5152.       DATA   ETA/376.73/
  5153.       XIJ= XI- XJ
  5154.       YIJ= YI- YJ
  5155.       RFL=-1.
  5156.       DO 7  IP=1, KSYMP
  5157.       RFL=- RFL
  5158.       SALPR= SALPJ* RFL
  5159.       ZIJ= ZI- RFL* ZJ
  5160.       ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR
  5161.       RHOX= XIJ- CABJ* ZP
  5162.       RHOY= YIJ- SABJ* ZP
  5163.       RHOZ= ZIJ- SALPR* ZP
  5164.       RH= SQRT( RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ+ AI* AI)
  5165.       IF( RH.GT.1.D-10) GOTO 1
  5166.       EXK=0.
  5167.       EYK=0.
  5168.       EZK=0.
  5169.       EXS=0.
  5170.       EYS=0.
  5171.       EZS=0.
  5172.       EXC=0.
  5173.       EYC=0.
  5174.       EZC=0.
  5175.       GOTO 7
  5176.     1 RHOX= RHOX/ RH
  5177.       RHOY= RHOY/ RH
  5178.       RHOZ= RHOZ/ RH
  5179.       PHX= SABJ* RHOZ- SALPR* RHOY
  5180.       PHY= SALPR* RHOX- CABJ* RHOZ
  5181.       PHZ= CABJ* RHOY- SABJ* RHOX
  5182.       CALL HSFLX( S, RH, ZP, HPK, HPS, HPC)
  5183.       IF( IP.NE.2) GOTO 6
  5184.       IF( IPERF.EQ.1) GOTO 5
  5185.       ZRATX= ZRATI
  5186.       RMAG= SQRT( ZP* ZP+ RH* RH)
  5187. C                                                                       
  5188. C     SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.                     
  5189. C                                                                       
  5190.       XYMAG= SQRT( XIJ* XIJ+ YIJ* YIJ)
  5191.       IF( NRADL.EQ.0) GOTO 2
  5192.       XSPEC=( XI* ZJ+ ZI* XJ)/( ZI+ ZJ)
  5193.       YSPEC=( YI* ZJ+ ZI* YJ)/( ZI+ ZJ)
  5194.       RHOSPC= SQRT( XSPEC* XSPEC+ YSPEC* YSPEC+ T2* T2)
  5195.       IF( RHOSPC.GT. SCRWL) GOTO 2
  5196.       RRV= T1* RHOSPC* LOG( RHOSPC/ T2)
  5197.       ZRATX=( RRV* ZRATI)/( ETA* ZRATI+ RRV)
  5198. C                                                                       
  5199. C     CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.  
  5200. C                                                                       
  5201.     2 IF( XYMAG.GT.1.D-6) GOTO 3
  5202.       PX=0.
  5203.       PY=0.
  5204.       CTH=1.
  5205.       RRV=(1.,0.)
  5206.       GOTO 4
  5207.     3 PX=- YIJ/ XYMAG
  5208.       PY= XIJ/ XYMAG
  5209.       CTH= ZIJ/ RMAG
  5210.       RRV= SQRT(1.- ZRATX* ZRATX*(1.- CTH* CTH))
  5211.     4 RRH= ZRATX* CTH
  5212.       RRH=-( RRH- RRV)/( RRH+ RRV)
  5213.       RRV= ZRATX* RRV
  5214.       RRV=( CTH- RRV)/( CTH+ RRV)
  5215.       QY=( PHX* PX+ PHY* PY)*( RRV- RRH)
  5216.       QX= QY* PX+ PHX* RRH
  5217.       QY= QY* PY+ PHY* RRH
  5218.       QZ= PHZ* RRH
  5219.       EXK= EXK- HPK* QX
  5220.       EYK= EYK- HPK* QY
  5221.       EZK= EZK- HPK* QZ
  5222.       EXS= EXS- HPS* QX
  5223.       EYS= EYS- HPS* QY
  5224.       EZS= EZS- HPS* QZ
  5225.       EXC= EXC- HPC* QX
  5226.       EYC= EYC- HPC* QY
  5227.       EZC= EZC- HPC* QZ
  5228.       GOTO 7
  5229.     5 EXK= EXK- HPK* PHX
  5230.       EYK= EYK- HPK* PHY
  5231.       EZK= EZK- HPK* PHZ
  5232.       EXS= EXS- HPS* PHX
  5233.       EYS= EYS- HPS* PHY
  5234.       EZS= EZS- HPS* PHZ
  5235.       EXC= EXC- HPC* PHX
  5236.       EYC= EYC- HPC* PHY
  5237.       EZC= EZC- HPC* PHZ
  5238.       GOTO 7
  5239.     6 EXK= HPK* PHX
  5240.       EYK= HPK* PHY
  5241.       EZK= HPK* PHZ
  5242.       EXS= HPS* PHX
  5243.       EYS= HPS* PHY
  5244.       EZS= HPS* PHZ
  5245.       EXC= HPC* PHX
  5246.       EYC= HPC* PHY
  5247.       EZC= HPC* PHZ
  5248.     7 CONTINUE
  5249.       RETURN
  5250.       END
  5251. C ***
  5252. C     DOUBLE PRECISION 6/4/85
  5253. C
  5254.       SUBROUTINE HSFLX( S, RH, ZPX, HPK, HPS, HPC)
  5255. C ***
  5256. C     CALCULATES H FIELD OF SINE COSINE, AND CONSTANT CURRENT OF SEGMENT
  5257.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  5258.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  5259.       COMPLEX  FJ, FJK, EKR1, EKR2, T1, T2, CONS, HPS, HPC, HPK
  5260.       DIMENSION  FJX(2), FJKX(2)
  5261.       EQUIVALENCE(FJ,FJX),(FJK,FJKX)
  5262.       DATA   TP/6.283185308D+0/, FJX/0.,1./, FJKX/0.,-6.283185308D+0/
  5263.       DATA   PI8/25.13274123D+0/
  5264.       IF( RH.LT.1.D-10) GOTO 6
  5265.       IF( ZPX.LT.0.) GOTO 1
  5266.       ZP= ZPX
  5267.       HSS=1.
  5268.       GOTO 2
  5269.     1 ZP=- ZPX
  5270.       HSS=-1.
  5271.     2 DH=.5* S
  5272.       Z1= ZP+ DH
  5273.       Z2= ZP- DH
  5274.       IF( Z2.LT.1.D-7) GOTO 3
  5275.       RHZ= RH/ Z2
  5276.       GOTO 4
  5277.     3 RHZ=1.
  5278.     4 DK= TP* DH
  5279.       CDK= COS( DK)
  5280.       SDK= SIN( DK)
  5281.       CALL HFK(- DK, DK, RH* TP, ZP* TP, HKR, HKI)
  5282.       HPK= CMPLX( HKR, HKI)
  5283.       IF( RHZ.LT.1.D-3) GOTO 5
  5284.       RH2= RH* RH
  5285.       R1= SQRT( RH2+ Z1* Z1)
  5286.       R2= SQRT( RH2+ Z2* Z2)
  5287.       EKR1= EXP( FJK* R1)
  5288.       EKR2= EXP( FJK* R2)
  5289.       T1= Z1* EKR1/ R1
  5290.       T2= Z2* EKR2/ R2
  5291.       HPS=( CDK*( EKR2- EKR1)- FJ* SDK*( T2+ T1))* HSS
  5292.       HPC=- SDK*( EKR2+ EKR1)- FJ* CDK*( T2- T1)
  5293.       CONS=- FJ/(2.* TP* RH)
  5294.       HPS= CONS* HPS
  5295.       HPC= CONS* HPC
  5296.       RETURN
  5297.     5 EKR1= CMPLX( CDK, SDK)/( Z2* Z2)
  5298.       EKR2= CMPLX( CDK,- SDK)/( Z1* Z1)
  5299.       T1= TP*(1./ Z1-1./ Z2)
  5300.       T2= EXP( FJK* ZP)* RH/ PI8
  5301.       HPS= T2*( T1+( EKR1+ EKR2)* SDK)* HSS
  5302.       HPC= T2*(- FJ* T1+( EKR1- EKR2)* CDK)
  5303.       RETURN
  5304.     6 HPS=(0.,0.)
  5305.       HPC=(0.,0.)
  5306.       HPK=(0.,0.)
  5307.       RETURN
  5308.       END
  5309. C ***
  5310. C     DOUBLE PRECISION 6/4/85
  5311. C
  5312.       SUBROUTINE INTRP( X, Y, F1, F2, F3, F4)
  5313. C ***
  5314. C                                                                       
  5315. C     INTRP USES BIVARIATE CUBIC INTERPOLATION TO OBTAIN THE VALUES OF  
  5316. C     4 FUNCTIONS AT THE POINT (X,Y).                                   
  5317. C                                                                       
  5318.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  5319.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  5320.       COMPLEX  F1, F2, F3, F4, A, B, C, D, FX1, FX2, FX3, FX4, P1, 
  5321.      &P2, P3, P4, A11, A12, A13, A14, A21, A22, A23, A24, A31, A32, A33
  5322.      &, A34, A41, A42, A43, A44, B11, B12, B13, B14, B21, B22, B23, B24
  5323.      &, B31, B32, B33, B34, B41, B42, B43, B44, C11, C12, C13, C14, C21
  5324.      &, C22, C23, C24, C31, C32, C33, C34, C41, C42, C43, C44, D11, D12
  5325.      &, D13, D14, D21, D22, D23, D24, D31, D32, D33, D34, D41, D42, D43
  5326.      &, D44
  5327.       COMPLEX  AR1, AR2, AR3, ARL1, ARL2, ARL3, EPSCF
  5328.       COMMON  /GGRID/ AR1(11,10,4), AR2(17,5,4), AR3(9,8,4), EPSCF, DXA
  5329.      &(3), DYA(3), XSA(3), YSA(3), NXA(3), NYA(3)
  5330.       DIMENSION  NDA(3), NDPA(3)
  5331.       DIMENSION  A(4,4), B(4,4), C(4,4), D(4,4), ARL1(1), ARL2(1), ARL3
  5332.      &(1)
  5333.       EQUIVALENCE(A(1,1),A11),(A(1,2),A12),(A(1,3),A13),(A(1,4),A14)
  5334.       EQUIVALENCE(A(2,1),A21),(A(2,2),A22),(A(2,3),A23),(A(2,4),A24)
  5335.       EQUIVALENCE(A(3,1),A31),(A(3,2),A32),(A(3,3),A33),(A(3,4),A34)
  5336.       EQUIVALENCE(A(4,1),A41),(A(4,2),A42),(A(4,3),A43),(A(4,4),A44)
  5337.       EQUIVALENCE(B(1,1),B11),(B(1,2),B12),(B(1,3),B13),(B(1,4),B14)
  5338.       EQUIVALENCE(B(2,1),B21),(B(2,2),B22),(B(2,3),B23),(B(2,4),B24)
  5339.       EQUIVALENCE(B(3,1),B31),(B(3,2),B32),(B(3,3),B33),(B(3,4),B34)
  5340.       EQUIVALENCE(B(4,1),B41),(B(4,2),B42),(B(4,3),B43),(B(4,4),B44)
  5341.       EQUIVALENCE(C(1,1),C11),(C(1,2),C12),(C(1,3),C13),(C(1,4),C14)
  5342.       EQUIVALENCE(C(2,1),C21),(C(2,2),C22),(C(2,3),C23),(C(2,4),C24)
  5343.       EQUIVALENCE(C(3,1),C31),(C(3,2),C32),(C(3,3),C33),(C(3,4),C34)
  5344.       EQUIVALENCE(C(4,1),C41),(C(4,2),C42),(C(4,3),C43),(C(4,4),C44)
  5345.       EQUIVALENCE(D(1,1),D11),(D(1,2),D12),(D(1,3),D13),(D(1,4),D14)
  5346.       EQUIVALENCE(D(2,1),D21),(D(2,2),D22),(D(2,3),D23),(D(2,4),D24)
  5347.       EQUIVALENCE(D(3,1),D31),(D(3,2),D32),(D(3,3),D33),(D(3,4),D34)
  5348.       EQUIVALENCE(D(4,1),D41),(D(4,2),D42),(D(4,3),D43),(D(4,4),D44)
  5349.       EQUIVALENCE(ARL1,AR1),(ARL2,AR2),(ARL3,AR3),(XS2,XSA(2)),(YS3,YSA
  5350.      &(3))
  5351.       DATA   IXS, IYS, IGRS/-10,-10,-10/, DX, DY, XS, YS/1.,1.,0.,0./
  5352.       DATA   NDA/11,17,9/, NDPA/110,85,72/, IXEG, IYEG/0,0/
  5353.       IF( X.LT. XS.OR. Y.LT. YS) GOTO 1
  5354.       IX= INT(( X- XS)/ DX)+1
  5355. C                                                                       
  5356. C     IF POINT LIES IN SAME 4 BY 4 POINT REGION AS PREVIOUS POINT, OLD  
  5357. C     VALUES ARE REUSED                                                 
  5358. C                                                                       
  5359.       IY= INT(( Y- YS)/ DY)+1
  5360.       IF( IX.LT. IXEG.OR. IY.LT. IYEG) GOTO 1
  5361. C                                                                       
  5362. C     DETERMINE CORRECT GRID AND GRID REGION                            
  5363. C                                                                       
  5364.       IF( IABS( IX- IXS).LT.2.AND. IABS( IY- IYS).LT.2) GOTO 12
  5365.     1 IF( X.GT. XS2) GOTO 2
  5366.       IGR=1
  5367.       GOTO 3
  5368.     2 IGR=2
  5369.       IF( Y.GT. YS3) IGR=3
  5370.     3 IF( IGR.EQ. IGRS) GOTO 4
  5371.       IGRS= IGR
  5372.       DX= DXA( IGRS)
  5373.       DY= DYA( IGRS)
  5374.       XS= XSA( IGRS)
  5375.       YS= YSA( IGRS)
  5376.       NXM2= NXA( IGRS)-2
  5377.       NYM2= NYA( IGRS)-2
  5378.       NXMS=(( NXM2+1)/3)*3+1
  5379.       NYMS=(( NYM2+1)/3)*3+1
  5380.       ND= NDA( IGRS)
  5381.       NDP= NDPA( IGRS)
  5382.       IX= INT(( X- XS)/ DX)+1
  5383.       IY= INT(( Y- YS)/ DY)+1
  5384.     4 IXS=(( IX-1)/3)*3+2
  5385.       IF( IXS.LT.2) IXS=2
  5386.       IXEG=-10000
  5387.       IF( IXS.LE. NXM2) GOTO 5
  5388.       IXS= NXM2
  5389.       IXEG= NXMS
  5390.     5 IYS=(( IY-1)/3)*3+2
  5391.       IF( IYS.LT.2) IYS=2
  5392.       IYEG=-10000
  5393.       IF( IYS.LE. NYM2) GOTO 6
  5394.       IYS= NYM2
  5395. C                                                                       
  5396. C     COMPUTE COEFFICIENTS OF 4 CUBIC POLYNOMIALS IN X FOR THE 4 GRID   
  5397. C     VALUES OF Y FOR EACH OF THE 4 FUNCTIONS                           
  5398. C                                                                       
  5399.       IYEG= NYMS
  5400.     6 IADZ= IXS+( IYS-3)* ND- NDP
  5401.       DO 11  K=1,4
  5402.       IADZ= IADZ+ NDP
  5403.       IADD= IADZ
  5404.       DO 11  I=1,4
  5405.       IADD= IADD+ ND
  5406. C     P1=AR1(IXS-1,IYS-2+I,K)                                           
  5407.       GOTO (7,8,9), IGRS
  5408.     7 P1= ARL1( IADD-1)
  5409.       P2= ARL1( IADD)
  5410.       P3= ARL1( IADD+1)
  5411.       P4= ARL1( IADD+2)
  5412.       GOTO 10
  5413.     8 P1= ARL2( IADD-1)
  5414.       P2= ARL2( IADD)
  5415.       P3= ARL2( IADD+1)
  5416.       P4= ARL2( IADD+2)
  5417.       GOTO 10
  5418.     9 P1= ARL3( IADD-1)
  5419.       P2= ARL3( IADD)
  5420.       P3= ARL3( IADD+1)
  5421.       P4= ARL3( IADD+2)
  5422.    10 A( I, K)=( P4- P1+3.*( P2- P3))*.1666666667D+0
  5423.       B( I, K)=( P1-2.* P2+ P3)*.5
  5424.       C( I, K)= P3-(2.* P1+3.* P2+ P4)*.1666666667D+0
  5425.    11 D( I, K)= P2
  5426.       XZ=( IXS-1)* DX+ XS
  5427. C                                                                       
  5428. C     EVALUATE POLYMOMIALS IN X AND THEN USE CUBIC INTERPOLATION IN Y   
  5429. C     FOR EACH OF THE 4 FUNCTIONS.                                      
  5430. C                                                                       
  5431.       YZ=( IYS-1)* DY+ YS
  5432.    12 XX=( X- XZ)/ DX
  5433.       YY=( Y- YZ)/ DY
  5434.       FX1=(( A11* XX+ B11)* XX+ C11)* XX+ D11
  5435.       FX2=(( A21* XX+ B21)* XX+ C21)* XX+ D21
  5436.       FX3=(( A31* XX+ B31)* XX+ C31)* XX+ D31
  5437.       FX4=(( A41* XX+ B41)* XX+ C41)* XX+ D41
  5438.       P1= FX4- FX1+3.*( FX2- FX3)
  5439.       P2=3.*( FX1-2.* FX2+ FX3)
  5440.       P3=6.* FX3-2.* FX1-3.* FX2- FX4
  5441.       F1=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2
  5442.       FX1=(( A12* XX+ B12)* XX+ C12)* XX+ D12
  5443.       FX2=(( A22* XX+ B22)* XX+ C22)* XX+ D22
  5444.       FX3=(( A32* XX+ B32)* XX+ C32)* XX+ D32
  5445.       FX4=(( A42* XX+ B42)* XX+ C42)* XX+ D42
  5446.       P1= FX4- FX1+3.*( FX2- FX3)
  5447.       P2=3.*( FX1-2.* FX2+ FX3)
  5448.       P3=6.* FX3-2.* FX1-3.* FX2- FX4
  5449.       F2=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2
  5450.       FX1=(( A13* XX+ B13)* XX+ C13)* XX+ D13
  5451.       FX2=(( A23* XX+ B23)* XX+ C23)* XX+ D23
  5452.       FX3=(( A33* XX+ B33)* XX+ C33)* XX+ D33
  5453.       FX4=(( A43* XX+ B43)* XX+ C43)* XX+ D43
  5454.       P1= FX4- FX1+3.*( FX2- FX3)
  5455.       P2=3.*( FX1-2.* FX2+ FX3)
  5456.       P3=6.* FX3-2.* FX1-3.* FX2- FX4
  5457.       F3=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2
  5458.       FX1=(( A14* XX+ B14)* XX+ C14)* XX+ D14
  5459.       FX2=(( A24* XX+ B24)* XX+ C24)* XX+ D24
  5460.       FX3=(( A34* XX+ B34)* XX+ C34)* XX+ D34
  5461.       FX4=(( A44* XX+ B44)* XX+ C44)* XX+ D44
  5462.       P1= FX4- FX1+3.*( FX2- FX3)
  5463.       P2=3.*( FX1-2.* FX2+ FX3)
  5464.       P3=6.* FX3-2.* FX1-3.* FX2- FX4
  5465.       F4=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2
  5466.       RETURN
  5467.       END
  5468. C ***
  5469. C     DOUBLE PRECISION 6/4/85
  5470. C
  5471.       SUBROUTINE INTX( EL1, EL2, B, IJ, SGR, SGI)
  5472. C ***
  5473. C                                                                       
  5474. C     INTX PERFORMS NUMERICAL INTEGRATION OF EXP(JKR)/R BY THE METHOD OF
  5475. C     VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION.  THE INTEGRAND VALUE 
  5476. C     IS SUPPLIED BY SUBROUTINE GF.                                     
  5477. C                                                                       
  5478.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  5479.       DATA   NX, NM, NTS, RX/1,65536,4,1.D-4/
  5480.       Z= EL1
  5481.       ZE= EL2
  5482.       IF( IJ.EQ.0) ZE=0.
  5483.       S= ZE- Z
  5484.       FNM= NM
  5485.       EP= S/(10.* FNM)
  5486.       ZEND= ZE- EP
  5487.       SGR=0.
  5488.       SGI=0.
  5489.       NS= NX
  5490.       NT=0
  5491.       CALL GF( Z, G1R, G1I)
  5492.     1 FNS= NS
  5493.       DZ= S/ FNS
  5494.       ZP= Z+ DZ
  5495.       IF( ZP- ZE) 3,3,2
  5496.     2 DZ= ZE- Z
  5497.       IF( ABS( DZ)- EP) 17,17,3
  5498.     3 DZOT= DZ*.5
  5499.       ZP= Z+ DZOT
  5500.       CALL GF( ZP, G3R, G3I)
  5501.       ZP= Z+ DZ
  5502.       CALL GF( ZP, G5R, G5I)
  5503.     4 T00R=( G1R+ G5R)* DZOT
  5504.       T00I=( G1I+ G5I)* DZOT
  5505.       T01R=( T00R+ DZ* G3R)*0.5
  5506.       T01I=( T00I+ DZ* G3I)*0.5
  5507.       T10R=(4.0* T01R- T00R)/3.0
  5508. C                                                                       
  5509. C     TEST CONVERGENCE OF 3 POINT ROMBERG RESULT.                       
  5510. C                                                                       
  5511.       T10I=(4.0* T01I- T00I)/3.0
  5512.       CALL TEST( T01R, T10R, TE1R, T01I, T10I, TE1I,0.)
  5513.       IF( TE1I- RX) 5,5,6
  5514.     5 IF( TE1R- RX) 8,8,6
  5515.     6 ZP= Z+ DZ*0.25
  5516.       CALL GF( ZP, G2R, G2I)
  5517.       ZP= Z+ DZ*0.75
  5518.       CALL GF( ZP, G4R, G4I)
  5519.       T02R=( T01R+ DZOT*( G2R+ G4R))*0.5
  5520.       T02I=( T01I+ DZOT*( G2I+ G4I))*0.5
  5521.       T11R=(4.0* T02R- T01R)/3.0
  5522.       T11I=(4.0* T02I- T01I)/3.0
  5523.       T20R=(16.0* T11R- T10R)/15.0
  5524. C                                                                       
  5525. C     TEST CONVERGENCE OF 5 POINT ROMBERG RESULT.                       
  5526. C                                                                       
  5527.       T20I=(16.0* T11I- T10I)/15.0
  5528.       CALL TEST( T11R, T20R, TE2R, T11I, T20I, TE2I,0.)
  5529.       IF( TE2I- RX) 7,7,14
  5530.     7 IF( TE2R- RX) 9,9,14
  5531.     8 SGR= SGR+ T10R
  5532.       SGI= SGI+ T10I
  5533.       NT= NT+2
  5534.       GOTO 10
  5535.     9 SGR= SGR+ T20R
  5536.       SGI= SGI+ T20I
  5537.       NT= NT+1
  5538.    10 Z= Z+ DZ
  5539.       IF( Z- ZEND) 11,17,17
  5540.    11 G1R= G5R
  5541.       G1I= G5I
  5542.       IF( NT- NTS) 1,12,12
  5543. C                                                                       
  5544. C     DOUBLE STEP SIZE                                                  
  5545. C                                                                       
  5546.    12 IF( NS- NX) 1,1,13
  5547.    13 NS= NS/2
  5548.       NT=1
  5549.       GOTO 1
  5550.    14 NT=0
  5551.       IF( NS- NM) 16,15,15
  5552.    15 WRITE( 6,20)  Z
  5553. C                                                                       
  5554. C     HALVE STEP SIZE                                                   
  5555. C                                                                       
  5556.       GOTO 9
  5557.    16 NS= NS*2
  5558.       FNS= NS
  5559.       DZ= S/ FNS
  5560.       DZOT= DZ*0.5
  5561.       G5R= G3R
  5562.       G5I= G3I
  5563.       G3R= G2R
  5564.       G3I= G2I
  5565.       GOTO 4
  5566.    17 CONTINUE
  5567. C                                                                       
  5568. C     ADD CONTRIBUTION OF NEAR SINGULARITY FOR DIAGONAL TERM            
  5569. C                                                                       
  5570.       IF( IJ) 19,18,19
  5571.    18 SGR=2.*( SGR+ LOG(( SQRT( B* B+ S* S)+ S)/ B))
  5572.       SGI=2.* SGI
  5573.    19 CONTINUE
  5574. C                                                                       
  5575.       RETURN
  5576.    20 FORMAT(' STEP SIZE LIMITED AT Z=',F10.5)
  5577.       END
  5578. C ***
  5579. C     DOUBLE PRECISION 6/4/85
  5580. C
  5581.       FUNCTION ISEGNO( ITAGI, MX)
  5582. C ***
  5583. C                                                                       
  5584. C     ISEGNO RETURNS THE SEGMENT NUMBER OF THE MTH SEGMENT HAVING THE   
  5585. C     TAG NUMBER ITAGI.  IF ITAGI=0 SEGMENT NUMBER M IS RETURNED.       
  5586. C                                                                       
  5587.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  5588.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  5589.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  5590.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  5591.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  5592.       IF( MX.GT.0) GOTO 1
  5593.       WRITE( 6,6) 
  5594.       STOP
  5595.     1 ICNT=0
  5596.       IF( ITAGI.NE.0) GOTO 2
  5597.       ISEGNO= MX
  5598.       RETURN
  5599.     2 IF( N.LT.1) GOTO 4
  5600.       DO 3  I=1, N
  5601.       IF( ITAG( I).NE. ITAGI) GOTO 3
  5602.       ICNT= ICNT+1
  5603.       IF( ICNT.EQ. MX) GOTO 5
  5604.     3 CONTINUE
  5605.     4 WRITE( 6,7)  ITAGI
  5606.       STOP
  5607.     5 ISEGNO= I
  5608. C                                                                       
  5609.       RETURN
  5610.     6 FORMAT(4X,'CHECK DATA, PARAMETER SPECIFYING SEGMENT POSITION IN',
  5611.      &' A GROUP OF EQUAL TAGS MUST NOT BE ZERO')
  5612.     7 FORMAT(///,10X,'NO SEGMENT HAS AN ITAG OF ',I5)
  5613.       END
  5614. C ***
  5615. C     DOUBLE PRECISION 6/4/85
  5616. C
  5617.       SUBROUTINE LFACTR( A, NROW, IX1, IX2, IP)
  5618. C ***
  5619. C                                                                       
  5620. C     LFACTR PERFORMS GAUSS-DOOLITTLE MANIPULATIONS ON THE TWO BLOCKS OF
  5621. C     THE TRANSPOSED MATRIX IN CORE STORAGE.  THE GAUSS-DOOLITTLE       
  5622. C     ALGORITHM IS PRESENTED ON PAGES 411-416 OF A. RALSTON -- A FIRST  
  5623. C     COURSE IN NUMERICAL ANALYSIS.  COMMENTS BELOW REFER TO COMMENTS IN
  5624. C     RALSTONS TEXT.                                                    
  5625. C                                                                       
  5626.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  5627.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  5628.       COMPLEX  A, D, AJR
  5629.       INTEGER  R, R1, R2, PJ, PR
  5630.       LOGICAL  L1, L2, L3
  5631.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  5632.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  5633.       COMMON  /SCRATM/ D( N2M)
  5634.       DIMENSION  A( NROW,1), IP( NROW)
  5635. C                                                                       
  5636. C     INITIALIZE R1,R2,J1,J2                                            
  5637. C                                                                       
  5638.       IFLG=0
  5639.       L1= IX1.EQ.1.AND. IX2.EQ.2
  5640.       L2=( IX2-1).EQ. IX1
  5641.       L3= IX2.EQ. NBLSYM
  5642.       IF( L1) GOTO 1
  5643.       GOTO 2
  5644.     1 R1=1
  5645.       R2=2* NPSYM
  5646.       J1=1
  5647.       J2=-1
  5648.       GOTO 5
  5649.     2 R1= NPSYM+1
  5650.       R2=2* NPSYM
  5651.       J1=( IX1-1)* NPSYM+1
  5652.       IF( L2) GOTO 3
  5653.       GOTO 4
  5654.     3 J2= J1+ NPSYM-2
  5655.       GOTO 5
  5656.     4 J2= J1+ NPSYM-1
  5657.     5 IF( L3) R2= NPSYM+ NLSYM
  5658. C                                                                       
  5659. C     STEP 1                                                            
  5660. C                                                                       
  5661.       DO 16  R= R1, R2
  5662.       DO 6  K= J1, NROW
  5663.       D( K)= A( K, R)
  5664. C                                                                       
  5665. C     STEPS 2 AND 3                                                     
  5666. C                                                                       
  5667.     6 CONTINUE
  5668.       IF( L1.OR. L2) J2= J2+1
  5669.       IF( J1.GT. J2) GOTO 9
  5670.       IXJ=0
  5671.       DO 8  J= J1, J2
  5672.       IXJ= IXJ+1
  5673.       PJ= IP( J)
  5674.       AJR= D( PJ)
  5675.       A( J, R)= AJR
  5676.       D( PJ)= D( J)
  5677.       JP1= J+1
  5678.       DO 7  I= JP1, NROW
  5679.       D( I)= D( I)- A( I, IXJ)* AJR
  5680.     7 CONTINUE
  5681.     8 CONTINUE
  5682. C                                                                       
  5683. C     STEP 4                                                            
  5684. C                                                                       
  5685.     9 CONTINUE
  5686.       J2P1= J2+1
  5687.       IF( L1.OR. L2) GOTO 11
  5688.       IF( NROW.LT. J2P1) GOTO 16
  5689.       DO 10  I= J2P1, NROW
  5690.       A( I, R)= D( I)
  5691.    10 CONTINUE
  5692.       GOTO 16
  5693.    11 DMAX= REAL( D( J2P1)* CONJG( D( J2P1)))
  5694.       IP( J2P1)= J2P1
  5695.       J2P2= J2+2
  5696.       IF( J2P2.GT. NROW) GOTO 13
  5697.       DO 12  I= J2P2, NROW
  5698.       ELMAG= REAL( D( I)* CONJG( D( I)))
  5699.       IF( ELMAG.LT. DMAX) GOTO 12
  5700.       DMAX= ELMAG
  5701.       IP( J2P1)= I
  5702.    12 CONTINUE
  5703.    13 CONTINUE
  5704.       IF( DMAX.LT.1.D-10) IFLG=1
  5705.       PR= IP( J2P1)
  5706.       A( J2P1, R)= D( PR)
  5707. C                                                                       
  5708. C     STEP 5                                                            
  5709. C                                                                       
  5710.       D( PR)= D( J2P1)
  5711.       IF( J2P2.GT. NROW) GOTO 15
  5712.       AJR=1./ A( J2P1, R)
  5713.       DO 14  I= J2P2, NROW
  5714.       A( I, R)= D( I)* AJR
  5715.    14 CONTINUE
  5716.    15 CONTINUE
  5717.       IF( IFLG.EQ.0) GOTO 16
  5718.       WRITE( 6,17)  J2, DMAX
  5719.       IFLG=0
  5720.    16 CONTINUE
  5721. C                                                                       
  5722.       RETURN
  5723.    17 FORMAT(' ','PIVOT(,I3,2H)=',1P,E16.8)
  5724.       END
  5725. C ***
  5726. C     DOUBLE PRECISION 6/4/85
  5727. C
  5728.       SUBROUTINE LOAD( LDTYP, LDTAG, LDTAGF, LDTAGT, ZLR, ZLI, ZLC)
  5729. C ***
  5730. C                                                                       
  5731. C     LOAD CALCULATES THE IMPEDANCE OF SPECIFIED SEGMENTS FOR VARIOUS   
  5732. C     TYPES OF LOADING                                                  
  5733. C                                                                       
  5734.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  5735.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  5736.       COMPLEX  ZARRAY, ZT, TPCJ, ZINT
  5737.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  5738.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  5739.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  5740.       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
  5741.       DIMENSION  LDTYP(1), LDTAG(1), LDTAGF(1), LDTAGT(1), ZLR(1), ZLI(
  5742.      &1), ZLC(1), TPCJX(2)
  5743.       EQUIVALENCE(TPCJ,TPCJX)
  5744. C                                                                       
  5745. C     WRITE(6,HEADING)                                                  
  5746. C                                                                       
  5747.       DATA   TPCJX/0.,1.883698955D+9/
  5748. C                                                                       
  5749. C     INITIALIZE D ARRAY, USED FOR TEMPORARY STORAGE OF LOADING         
  5750. C     INFORMATION.                                                      
  5751. C                                                                       
  5752.       WRITE( 6,25) 
  5753.       DO 1  I= N2, N
  5754.     1 ZARRAY( I)=(0.,0.)
  5755. C                                                                       
  5756. C     CYCLE OVER LOADING CARDS                                          
  5757. C                                                                       
  5758.       IWARN=0
  5759.       ISTEP=0
  5760.     2 ISTEP= ISTEP+1
  5761.       IF( ISTEP.LE. NLOAD) GOTO 5
  5762.       IF( IWARN.EQ.1) WRITE( 6,26) 
  5763.       IF( N1+2* M1.GT.0) GOTO 4
  5764.       NOP= N/ NP
  5765.       IF( NOP.EQ.1) GOTO 4
  5766.       DO 3  I=1, NP
  5767.       ZT= ZARRAY( I)
  5768.       L1= I
  5769.       DO 3  L2=2, NOP
  5770.       L1= L1+ NP
  5771.     3 ZARRAY( L1)= ZT
  5772.     4 RETURN
  5773.     5 IF( LDTYP( ISTEP).LE.5) GOTO 6
  5774.       WRITE( 6,27)  LDTYP( ISTEP)
  5775.       STOP
  5776.     6 LDTAGS= LDTAG( ISTEP)
  5777.       JUMP= LDTYP( ISTEP)+1
  5778. C                                                                       
  5779. C     SEARCH SEGMENTS FOR PROPER ITAGS                                  
  5780. C                                                                       
  5781.       ICHK=0
  5782.       L1= N2
  5783.       L2= N
  5784.       IF( LDTAGS.NE.0) GOTO 7
  5785.       IF( LDTAGF( ISTEP).EQ.0.AND. LDTAGT( ISTEP).EQ.0) GOTO 7
  5786.       L1= LDTAGF( ISTEP)
  5787.       L2= LDTAGT( ISTEP)
  5788.       IF( L1.GT. N1) GOTO 7
  5789.       WRITE( 6,29) 
  5790.       STOP
  5791.     7 DO 17  I= L1, L2
  5792.       IF( LDTAGS.EQ.0) GOTO 8
  5793.       IF( LDTAGS.NE. ITAG( I)) GOTO 17
  5794.       IF( LDTAGF( ISTEP).EQ.0) GOTO 8
  5795.       ICHK= ICHK+1
  5796.       IF( ICHK.GE. LDTAGF( ISTEP).AND. ICHK.LE. LDTAGT( ISTEP)) GOTO 9
  5797.       GOTO 17
  5798. C                                                                       
  5799. C     CALCULATION OF LAMDA*IMPED. PER UNIT LENGTH, JUMP TO APPROPRIATE  
  5800. C     SECTION FOR LOADING TYPE                                          
  5801. C                                                                       
  5802.     8 ICHK=1
  5803.     9 GOTO (10,11,12,13,14,15), JUMP
  5804.    10 ZT= ZLR( ISTEP)/ SI( I)+ TPCJ* ZLI( ISTEP)/( SI( I)* WLAM)
  5805.       IF( ABS( ZLC( ISTEP)).GT.1.D-20) ZT= ZT+ WLAM/( TPCJ* SI( I)* ZLC
  5806.      &( ISTEP))
  5807.       GOTO 16
  5808.    11 ZT= TPCJ* SI( I)* ZLC( ISTEP)/ WLAM
  5809.       IF( ABS( ZLI( ISTEP)).GT.1.D-20) ZT= ZT+ SI( I)* WLAM/( TPCJ* ZLI
  5810.      &( ISTEP))
  5811.       IF( ABS( ZLR( ISTEP)).GT.1.D-20) ZT= ZT+ SI( I)/ ZLR( ISTEP)
  5812.       ZT=1./ ZT
  5813.       GOTO 16
  5814.    12 ZT= ZLR( ISTEP)* WLAM+ TPCJ* ZLI( ISTEP)
  5815.       IF( ABS( ZLC( ISTEP)).GT.1.D-20) ZT= ZT+1./( TPCJ* SI( I)* SI( I)
  5816.      &* ZLC( ISTEP))
  5817.       GOTO 16
  5818.    13 ZT= TPCJ* SI( I)* SI( I)* ZLC( ISTEP)
  5819.       IF( ABS( ZLI( ISTEP)).GT.1.D-20) ZT= ZT+1./( TPCJ* ZLI( ISTEP))
  5820.       IF( ABS( ZLR( ISTEP)).GT.1.D-20) ZT= ZT+1./( ZLR( ISTEP)* WLAM)
  5821.       ZT=1./ ZT
  5822.       GOTO 16
  5823.    14 ZT= CMPLX( ZLR( ISTEP), ZLI( ISTEP))/ SI( I)
  5824.       GOTO 16
  5825.    15 ZT= ZINT( ZLR( ISTEP)* WLAM, BI( I))
  5826.    16 IF(( ABS( REAL( ZARRAY( I)))+ ABS( AIMAG( ZARRAY( I)))).GT.1.D-20
  5827.      &) IWARN=1
  5828.       ZARRAY( I)= ZARRAY( I)+ ZT
  5829.    17 CONTINUE
  5830.       IF( ICHK.NE.0) GOTO 18
  5831.       WRITE( 6,28)  LDTAGS
  5832. C                                                                       
  5833. C     PRINTING THE SEGMENT LOADING DATA, JUMP TO PROPER PRINT           
  5834. C                                                                       
  5835.       STOP
  5836.    18 GOTO (19,20,21,22,23,24), JUMP
  5837.    19 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP), ZLR( ISTEP), 
  5838.      &ZLI( ISTEP), ZLC( ISTEP),0.,0.,0.,8H SERIES ,2)
  5839.       GOTO 2
  5840.    20 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP), ZLR( ISTEP), 
  5841.      &ZLI( ISTEP), ZLC( ISTEP),0.,0.,0.,8HPARALLEL,2)
  5842.       GOTO 2
  5843.    21 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP), ZLR( ISTEP), 
  5844.      &ZLI( ISTEP), ZLC( ISTEP),0.,0.,0.,20HSERIES (PER METER),5)
  5845.       GOTO 2
  5846.    22 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP), ZLR( ISTEP), 
  5847.      &ZLI( ISTEP), ZLC( ISTEP),0.,0.,0.,20HPARALLEL (PER METER),5)
  5848.       GOTO 2
  5849.    23 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP),0.,0.,0., ZLR( 
  5850.      &ISTEP), ZLI( ISTEP),0.,16HFIXED IMPEDANCE ,4)
  5851.       GOTO 2
  5852.    24 CALL PRNT( LDTAGS, LDTAGF( ISTEP), LDTAGT( ISTEP),0.,0.,0.,0.,0.,
  5853.      & ZLR( ISTEP),8H  WIRE  ,2)
  5854. C                                                                       
  5855.       GOTO 2
  5856.    25 FORMAT(//,7X,'LOCATION',10X,'RESISTANCE',3X,'INDUCTANCE',2X,
  5857.      &'CAPACITANCE',7X,'IMPEDANCE (OHMS)',5X,'CONDUCTIVITY',4X,'TYPE',/
  5858.      &,4X,'ITAG',' FROM THRU',10X,'OHMS',8X,'HENRYS',7X,'FARADS',8X,
  5859.      &'REAL',6X,'IMAGINARY',4X,'MHOS/METER')
  5860.    26 FORMAT(/,10X,'NOTE, SOME OF THE ABOVE SEGMENTS HAVE BEEN LOADED',
  5861.      &' TWICE - IMPEDANCES ADDED')
  5862.    27 FORMAT(/,10X,'IMPROPER LOAD TYPE CHOOSEN, REQUESTED TYPE IS ',I3)
  5863.      &
  5864.    28 FORMAT(/,10X,'LOADING DATA CARD ERROR, NO SEGMENT HAS AN ITAG =',
  5865.      &I5)
  5866.    29 FORMAT(' ERROR - LOADING MAY NOT BE ADDED TO SEGMENTS IN N.G.F.'
  5867.      &' SECTION')
  5868.       END
  5869. C ***
  5870. C     DOUBLE PRECISION 6/4/85
  5871. C
  5872.       SUBROUTINE LTSOLV( A, NROW, IX, B, NEQ, NRH, IFL1, IFL2)
  5873. C ***
  5874. C                                                                       
  5875. C     LTSOLV SOLVES THE MATRIX EQ. Y(R)*LU(T)=B(R) WHERE (R) DENOTES ROW
  5876. C     VECTOR AND LU(T) DENOTES THE LU DECOMPOSITION OF THE TRANSPOSE OF 
  5877. C     THE ORIGINAL COEFFICIENT MATRIX.  THE LU(T) DECOMPOSITION IS      
  5878. C     STORED ON TAPE 5 IN BLOCKS IN ASCENDING ORDER AND ON FILE 3 IN    
  5879. C     BLOCKS OF DESCENDING ORDER.                                       
  5880. C                                                                       
  5881.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  5882.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  5883.       COMPLEX  A, B, Y, SUM
  5884.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  5885.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  5886.       COMMON  /SCRATM/ Y( N2M)
  5887. C                                                                       
  5888. C     FORWARD SUBSTITUTION                                              
  5889. C                                                                       
  5890.       DIMENSION  A( NROW, NROW), B( NEQ, NRH), IX( NEQ)
  5891.       I2=2* NPSYM* NROW
  5892.       DO 4  IXBLK1=1, NBLSYM
  5893.       CALL BLCKIN( A, IFL1,1, I2,1,121)
  5894.       K2= NPSYM
  5895.       IF( IXBLK1.EQ. NBLSYM) K2= NLSYM
  5896.       JST=( IXBLK1-1)* NPSYM
  5897.       DO 4  IC=1, NRH
  5898.       J= JST
  5899.       DO 3  K=1, K2
  5900.       JM1= J
  5901.       J= J+1
  5902.       SUM=(0.,0.)
  5903.       IF( JM1.LT.1) GOTO 2
  5904.       DO 1  I=1, JM1
  5905.     1 SUM= SUM+ A( I, K)* B( I, IC)
  5906.     2 B( J, IC)=( B( J, IC)- SUM)/ A( J, K)
  5907.     3 CONTINUE
  5908. C                                                                       
  5909. C     BACKWARD SUBSTITUTION                                             
  5910. C                                                                       
  5911.     4 CONTINUE
  5912.       JST= NROW+1
  5913.       DO 8  IXBLK1=1, NBLSYM
  5914.       CALL BLCKIN( A, IFL2,1, I2,1,122)
  5915.       K2= NPSYM
  5916.       IF( IXBLK1.EQ.1) K2= NLSYM
  5917.       DO 7  IC=1, NRH
  5918.       KP= K2+1
  5919.       J= JST
  5920.       DO 6  K=1, K2
  5921.       KP= KP-1
  5922.       JP1= J
  5923.       J= J-1
  5924.       SUM=(0.,0.)
  5925.       IF( NROW.LT. JP1) GOTO 6
  5926.       DO 5  I= JP1, NROW
  5927.     5 SUM= SUM+ A( I, KP)* B( I, IC)
  5928.       B( J, IC)= B( J, IC)- SUM
  5929.     6 CONTINUE
  5930.     7 CONTINUE
  5931. C                                                                       
  5932. C     UNSCRAMBLE SOLUTION                                               
  5933. C                                                                       
  5934.     8 JST= JST- K2
  5935.       DO 10  IC=1, NRH
  5936.       DO 9  I=1, NROW
  5937.       IXI= IX( I)
  5938.     9 Y( IXI)= B( I, IC)
  5939.       DO 10  I=1, NROW
  5940.    10 B( I, IC)= Y( I)
  5941.       RETURN
  5942.       END
  5943. C ***
  5944. C     DOUBLE PRECISION 6/4/85
  5945. C
  5946.       SUBROUTINE LUNSCR( A, NROW, NOP, IX, IP, IU2, IU3, IU4)
  5947. C ***
  5948. C                                                                       
  5949. C     S/R WHICH UNSCRAMBLES, SCRAMBLED FACTORED MATRIX                  
  5950. C                                                                       
  5951.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  5952.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  5953.       COMPLEX  A, TEMP
  5954.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  5955.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  5956.       DIMENSION  A( NROW,1), IP( NROW), IX( NROW)
  5957.       I1=1
  5958.       I2=2* NPSYM* NROW
  5959.       NM1= NROW-1
  5960.       REWIND IU2
  5961.       REWIND IU3
  5962.       REWIND IU4
  5963.       DO 9  KK=1, NOP
  5964.       KA=( KK-1)* NROW
  5965.       DO 4  IXBLK1=1, NBLSYM
  5966.       CALL BLCKIN( A, IU2, I1, I2,1,121)
  5967.       K1=( IXBLK1-1)* NPSYM+2
  5968.       IF( NM1.LT. K1) GOTO 3
  5969.       J2=0
  5970.       DO 2  K= K1, NM1
  5971.       IF( J2.LT. NPSYM) J2= J2+1
  5972.       IPK= IP( K+ KA)
  5973.       DO 1  J=1, J2
  5974.       TEMP= A( K, J)
  5975.       A( K, J)= A( IPK, J)
  5976.       A( IPK, J)= TEMP
  5977.     1 CONTINUE
  5978.     2 CONTINUE
  5979.     3 CONTINUE
  5980.       CALL BLCKOT( A, IU3, I1, I2,1,122)
  5981.     4 CONTINUE
  5982.       DO 5  IXBLK1=1, NBLSYM
  5983.       BACKSPACE IU3
  5984.       IF( IXBLK1.NE.1) BACKSPACE IU3
  5985.       CALL BLCKIN( A, IU3, I1, I2,1,123)
  5986.       CALL BLCKOT( A, IU4, I1, I2,1,124)
  5987.     5 CONTINUE
  5988.       DO 6  I=1, NROW
  5989.       IX( I+ KA)= I
  5990.     6 CONTINUE
  5991.       DO 7  I=1, NROW
  5992.       IPI= IP( I+ KA)
  5993.       IXT= IX( I+ KA)
  5994.       IX( I+ KA)= IX( IPI+ KA)
  5995.       IX( IPI+ KA)= IXT
  5996.     7 CONTINUE
  5997.       IF( NOP.EQ.1) GOTO 9
  5998. C     SKIP NB1 LOGICAL RECORDS FORWARD                                  
  5999.       NB1= NBLSYM-1
  6000.       DO 8  IXBLK1=1, NB1
  6001.       CALL BLCKIN( A, IU3, I1, I2,1,125)
  6002.     8 CONTINUE
  6003.     9 CONTINUE
  6004.       REWIND IU2
  6005.       REWIND IU3
  6006.       REWIND IU4
  6007.       RETURN
  6008.       END
  6009. C ***
  6010. C     DOUBLE PRECISION 6/4/85
  6011. C
  6012.       SUBROUTINE MOVE( ROX, ROY, ROZ, XS, YS, ZS, ITS, NRPT, ITGI)
  6013. C ***
  6014. C                                                                       
  6015. C     SUBROUTINE MOVE MOVES THE STRUCTURE WITH RESPECT TO ITS           
  6016. C     COORDINATE SYSTEM OR REPRODUCES STRUCTURE IN NEW POSITIONS.       
  6017. C     STRUCTURE IS ROTATED ABOUT X,Y,Z AXES BY ROX,ROY,ROZ              
  6018. C     RESPECTIVELY, THEN SHIFTED BY XS,YS,ZS                            
  6019. C                                                                       
  6020.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  6021.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  6022.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  6023.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  6024.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  6025.       COMMON  /ANGL/ SALP( NM)
  6026.       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), X2(1),
  6027.      & Y2(1), Z2(1)
  6028.       EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1))
  6029.       EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
  6030.      &T2Z,ITAG)
  6031.       IF( ABS( ROX)+ ABS( ROY).GT.1.D-10) IPSYM= IPSYM*3
  6032.       SPS= SIN( ROX)
  6033.       CPS= COS( ROX)
  6034.       STH= SIN( ROY)
  6035.       CTH= COS( ROY)
  6036.       SPH= SIN( ROZ)
  6037.       CPH= COS( ROZ)
  6038.       XX= CPH* CTH
  6039.       XY= CPH* STH* SPS- SPH* CPS
  6040.       XZ= CPH* STH* CPS+ SPH* SPS
  6041.       YX= SPH* CTH
  6042.       YY= SPH* STH* SPS+ CPH* CPS
  6043.       YZ= SPH* STH* CPS- CPH* SPS
  6044.       ZX=- STH
  6045.       ZY= CTH* SPS
  6046.       ZZ= CTH* CPS
  6047.       NRP= NRPT
  6048.       IF( NRPT.EQ.0) NRP=1
  6049.       IX=1
  6050.       IF( N.LT. N2) GOTO 3
  6051.       I1= ISEGNO( ITS,1)
  6052.       IF( I1.LT. N2) I1= N2
  6053.       IX= I1
  6054.       K= N
  6055.       IF( NRPT.EQ.0) K= I1-1
  6056.       DO 2  IR=1, NRP
  6057.       DO 1  I= I1, N
  6058.       K= K+1
  6059.       XI= X( I)
  6060.       YI= Y( I)
  6061.       ZI= Z( I)
  6062.       X( K)= XI* XX+ YI* XY+ ZI* XZ+ XS
  6063.       Y( K)= XI* YX+ YI* YY+ ZI* YZ+ YS
  6064.       Z( K)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS
  6065.       XI= X2( I)
  6066.       YI= Y2( I)
  6067.       ZI= Z2( I)
  6068.       X2( K)= XI* XX+ YI* XY+ ZI* XZ+ XS
  6069.       Y2( K)= XI* YX+ YI* YY+ ZI* YZ+ YS
  6070.       Z2( K)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS
  6071.       BI( K)= BI( I)
  6072.       ITAG( K)= ITAG( I)
  6073.       IF( ITAG( I).NE.0) ITAG( K)= ITAG( I)+ ITGI
  6074.     1 CONTINUE
  6075.       I1= N+1
  6076.       N= K
  6077.     2 CONTINUE
  6078.     3 IF( M.LT. M2) GOTO 6
  6079.       I1= M2
  6080.       K= M
  6081.       LDI= LD+1
  6082.       IF( NRPT.EQ.0) K= M1
  6083.       DO 5  II=1, NRP
  6084.       DO 4  I= I1, M
  6085.       K= K+1
  6086.       IR= LDI- I
  6087.       KR= LDI- K
  6088.       XI= X( IR)
  6089.       YI= Y( IR)
  6090.       ZI= Z( IR)
  6091.       X( KR)= XI* XX+ YI* XY+ ZI* XZ+ XS
  6092.       Y( KR)= XI* YX+ YI* YY+ ZI* YZ+ YS
  6093.       Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS
  6094.       XI= T1X( IR)
  6095.       YI= T1Y( IR)
  6096.       ZI= T1Z( IR)
  6097.       T1X( KR)= XI* XX+ YI* XY+ ZI* XZ
  6098.       T1Y( KR)= XI* YX+ YI* YY+ ZI* YZ
  6099.       T1Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ
  6100.       XI= T2X( IR)
  6101.       YI= T2Y( IR)
  6102.       ZI= T2Z( IR)
  6103.       T2X( KR)= XI* XX+ YI* XY+ ZI* XZ
  6104.       T2Y( KR)= XI* YX+ YI* YY+ ZI* YZ
  6105.       T2Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ
  6106.       SALP( KR)= SALP( IR)
  6107.     4 BI( KR)= BI( IR)
  6108.       I1= M+1
  6109.     5 M= K
  6110.     6 IF(( NRPT.EQ.0).AND.( IX.EQ.1)) RETURN
  6111.       NP= N
  6112.       MP= M
  6113.       IPSYM=0
  6114.       RETURN
  6115.       END
  6116. C ***
  6117. C     DOUBLE PRECISION 6/4/85
  6118. C
  6119.       SUBROUTINE NEFLD( XOB, YOB, ZOB, EX, EY, EZ)
  6120. C ***
  6121. C                                                                       
  6122. C     NEFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER  
  6123. C     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.                        
  6124. C                                                                       
  6125.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  6126.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  6127.       COMPLEX  EX, EY, EZ, CUR, ACX, BCX, CCX, EXK, EYK, EZK, EXS, 
  6128.      &EYS, EZS, EXC, EYC, EZC, ZRATI, ZRATI2, T1, FRATI
  6129.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  6130.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  6131.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  6132.       COMMON  /ANGL/ SALP( NM)
  6133.       COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM), 
  6134.      &CII( NM), CUR( N3M)
  6135.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  6136.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  6137.      &INDD2, IPGND
  6138.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  6139.      &KSYMP, IFAR, IPERF, T1, T2
  6140.       DIMENSION  CAB(1), SAB(1), T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1)
  6141.      &, T2Z(1)
  6142.       EQUIVALENCE(CAB,ALP),(SAB,BET)
  6143.       EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
  6144.      &T2Z,ITAG)
  6145.       EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
  6146.      &IND1),(T2ZJ,IND2)
  6147.       EX=(0.,0.)
  6148.       EY=(0.,0.)
  6149.       EZ=(0.,0.)
  6150.       AX=0.
  6151.       IF( N.EQ.0) GOTO 20
  6152.       DO 1  I=1, N
  6153.       XJ= XOB- X( I)
  6154.       YJ= YOB- Y( I)
  6155.       ZJ= ZOB- Z( I)
  6156.       ZP= CAB( I)* XJ+ SAB( I)* YJ+ SALP( I)* ZJ
  6157.       IF( ABS( ZP).GT.0.5001* SI( I)) GOTO 1
  6158.       ZP= XJ* XJ+ YJ* YJ+ ZJ* ZJ- ZP* ZP
  6159.       XJ= BI( I)
  6160.       IF( ZP.GT.0.9* XJ* XJ) GOTO 1
  6161.       AX= XJ
  6162.       GOTO 2
  6163.     1 CONTINUE
  6164.     2 DO 19  I=1, N
  6165.       S= SI( I)
  6166.       B= BI( I)
  6167.       XJ= X( I)
  6168.       YJ= Y( I)
  6169.       ZJ= Z( I)
  6170.       CABJ= CAB( I)
  6171.       SABJ= SAB( I)
  6172.       SALPJ= SALP( I)
  6173.       IF( IEXK.EQ.0) GOTO 18
  6174.       IPR= ICON1( I)
  6175.       IF( IPR) 3,8,4
  6176.     3 IPR=- IPR
  6177.       IF(- ICON1( IPR).NE. I) GOTO 9
  6178.       GOTO 6
  6179.     4 IF( IPR.NE. I) GOTO 5
  6180.       IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 9
  6181.       GOTO 7
  6182.     5 IF( ICON2( IPR).NE. I) GOTO 9
  6183.     6 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
  6184.       IF( XI.LT.0.999999D+0) GOTO 9
  6185.       IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 9
  6186.     7 IND1=0
  6187.       GOTO 10
  6188.     8 IND1=1
  6189.       GOTO 10
  6190.     9 IND1=2
  6191.    10 IPR= ICON2( I)
  6192.       IF( IPR) 11,16,12
  6193.    11 IPR=- IPR
  6194.       IF(- ICON2( IPR).NE. I) GOTO 17
  6195.       GOTO 14
  6196.    12 IF( IPR.NE. I) GOTO 13
  6197.       IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 17
  6198.       GOTO 15
  6199.    13 IF( ICON1( IPR).NE. I) GOTO 17
  6200.    14 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
  6201.       IF( XI.LT.0.999999D+0) GOTO 17
  6202.       IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 17
  6203.    15 IND2=0
  6204.       GOTO 18
  6205.    16 IND2=1
  6206.       GOTO 18
  6207.    17 IND2=2
  6208.    18 CONTINUE
  6209.       CALL EFLD( XOB, YOB, ZOB, AX,1)
  6210.       ACX= CMPLX( AIR( I), AII( I))
  6211.       BCX= CMPLX( BIR( I), BII( I))
  6212.       CCX= CMPLX( CIR( I), CII( I))
  6213.       EX= EX+ EXK* ACX+ EXS* BCX+ EXC* CCX
  6214.       EY= EY+ EYK* ACX+ EYS* BCX+ EYC* CCX
  6215.    19 EZ= EZ+ EZK* ACX+ EZS* BCX+ EZC* CCX
  6216.       IF( M.EQ.0) RETURN
  6217.    20 JC= N
  6218.       JL= LD+1
  6219.       DO 21  I=1, M
  6220.       JL= JL-1
  6221.       S= BI( JL)
  6222.       XJ= X( JL)
  6223.       YJ= Y( JL)
  6224.       ZJ= Z( JL)
  6225.       T1XJ= T1X( JL)
  6226.       T1YJ= T1Y( JL)
  6227.       T1ZJ= T1Z( JL)
  6228.       T2XJ= T2X( JL)
  6229.       T2YJ= T2Y( JL)
  6230.       T2ZJ= T2Z( JL)
  6231.       JC= JC+3
  6232.       ACX= T1XJ* CUR( JC-2)+ T1YJ* CUR( JC-1)+ T1ZJ* CUR( JC)
  6233.       BCX= T2XJ* CUR( JC-2)+ T2YJ* CUR( JC-1)+ T2ZJ* CUR( JC)
  6234.       DO 21  IP=1, KSYMP
  6235.       IPGND= IP
  6236.       CALL UNERE( XOB, YOB, ZOB)
  6237.       EX= EX+ ACX* EXK+ BCX* EXS
  6238.       EY= EY+ ACX* EYK+ BCX* EYS
  6239.    21 EZ= EZ+ ACX* EZK+ BCX* EZS
  6240.       RETURN
  6241.       END
  6242. C ***
  6243. C     DOUBLE PRECISION 6/4/85
  6244. C
  6245.       SUBROUTINE NETWK( CM, CMB, CMC, CMD, IP, EINC) 
  6246. C *** 
  6247. C                                                                       
  6248. C     SUBROUTINE NETWK SOLVES FOR STRUCTURE CURRENTS FOR A GIVEN        
  6249. C     EXCITATION INCLUDING THE EFFECT OF NON-RADIATING NETWORKS IF      
  6250. C     PRESENT.                                                          
  6251. C                                                                       
  6252.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  6253.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  6254.       COMPLEX  CMN, RHNT, YMIT, RHS, ZPED, EINC, VSANT, VLT, CUR, 
  6255.      &VSRC, RHNX, VQD, VQDS, CUX, CM, CMB, CMC, CMD
  6256.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  6257.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  6258.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  6259.       COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM), 
  6260.      &CII( NM), CUR( N3M)
  6261.       COMMON  /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
  6262.      &, IQDS(30), NVQD, NSANT, NQDS
  6263.       COMMON/NETCX/ZPED,PIN,PNLS,X11R(150),X11I(150),X12R(150),
  6264.      &X12I(150),X22R(150),X22I(150),NTYP(150),NEQ,NPEQ,NEQ2,NONET,NTSOL
  6265.      &,NPRINT,MASYM,ISEG1(150),ISEG2(150)
  6266.       DIMENSION  EINC(1), IP(1), CM(1), CMB(1), CMC(1), CMD(1)
  6267.       DIMENSION  CMN(150,150), RHNT(150), IPNT(150), NTEQA(150),  
  6268.      &NTSCA(150), RHS( N3M), VSRC(10), RHNX(150)
  6269.       DATA   NDIMN, NDIMNP/150,151/, TP/6.283185308D+0/
  6270.       NEQZ2= NEQ2
  6271.       IF( NEQZ2.EQ.0) NEQZ2=1
  6272.       PIN=0.
  6273.       PNLS=0.
  6274.       NEQT= NEQ+ NEQ2
  6275.       IF( NTSOL.NE.0) GOTO 42
  6276.       NOP= NEQ/ NPEQ
  6277. C                                                                       
  6278. C     COMPUTE RELATIVE MATRIX ASYMMETRY                                 
  6279. C                                                                       
  6280.       IF( MASYM.EQ.0) GOTO 14
  6281.       IROW1=0
  6282.       IF( NONET.EQ.0) GOTO 5
  6283.       DO 4  I=1, NONET
  6284.       NSEG1= ISEG1( I)
  6285.       DO 3  ISC1=1,2
  6286.       IF( IROW1.EQ.0) GOTO 2
  6287.       DO 1  J=1, IROW1
  6288.       IF( NSEG1.EQ. IPNT( J)) GOTO 3
  6289.     1 CONTINUE
  6290.     2 IROW1= IROW1+1
  6291.       IPNT( IROW1)= NSEG1
  6292.     3 NSEG1= ISEG2( I)
  6293.     4 CONTINUE
  6294.     5 IF( NSANT.EQ.0) GOTO 9
  6295.       DO 8  I=1, NSANT
  6296.       NSEG1= ISANT( I)
  6297.       IF( IROW1.EQ.0) GOTO 7
  6298.       DO 6  J=1, IROW1
  6299.       IF( NSEG1.EQ. IPNT( J)) GOTO 8
  6300.     6 CONTINUE
  6301.     7 IROW1= IROW1+1
  6302.       IPNT( IROW1)= NSEG1
  6303.     8 CONTINUE
  6304.     9 IF( IROW1.LT. NDIMNP) GOTO 10
  6305.       WRITE( 6,59) 
  6306.       STOP
  6307.    10 IF( IROW1.LT.2) GOTO 14
  6308.       DO 12  I=1, IROW1
  6309.       ISC1= IPNT( I)
  6310.       ASM= SI( ISC1)
  6311.       DO 11  J=1, NEQT
  6312.    11 RHS( J)=(0.,0.)
  6313.       RHS( ISC1)=(1.,0.)
  6314.       CALL SOLGF( CM, CMB, CMC, CMD, RHS, IP, NP, N1, N, MP, M1, M, NEQ
  6315.      &, NEQ2, NEQZ2)
  6316.       CALL CABC( RHS)
  6317.       DO 12  J=1, IROW1
  6318.       ISC1= IPNT( J)
  6319.    12 CMN( J, I)= RHS( ISC1)/ ASM
  6320.       ASM=0.
  6321.       ASA=0.
  6322.       DO 13  I=2, IROW1
  6323.       ISC1= I-1
  6324.       DO 13  J=1, ISC1
  6325.       CUX= CMN( I, J)
  6326.       PWR= ABS(( CUX- CMN( J, I))/ CUX)
  6327.       ASA= ASA+ PWR* PWR
  6328.       IF( PWR.LT. ASM) GOTO 13
  6329.       ASM= PWR
  6330.       NTEQ= IPNT( I)
  6331.       NTSC= IPNT( J)
  6332.    13 CONTINUE
  6333.       ASA= SQRT( ASA*2./ DFLOAT( IROW1*( IROW1-1)))
  6334.       WRITE( 6,58)  ASM, NTEQ, NTSC, ASA
  6335. C                                                                       
  6336. C     SOLUTION OF NETWORK EQUATIONS                                     
  6337. C                                                                       
  6338.    14 IF( NONET.EQ.0) GOTO 48
  6339.       DO 15  I=1, NDIMN
  6340.       RHNX( I)=(0.,0.)
  6341.       DO 15  J=1, NDIMN
  6342.    15 CMN( I, J)=(0.,0.)
  6343.       NTEQ=0
  6344. C                                                                       
  6345. C     SORT NETWORK AND SOURCE DATA AND ASSIGN EQUATION NUMBERS TO       
  6346. C     SEGMENTS.                                                         
  6347. C                                                                       
  6348.       NTSC=0
  6349.       DO 38  J=1, NONET
  6350.       NSEG1= ISEG1( J)
  6351.       NSEG2= ISEG2( J)
  6352.       IF( NTYP( J).GT.1) GOTO 16
  6353.       Y11R= X11R( J)
  6354.       Y11I= X11I( J)
  6355.       Y12R= X12R( J)
  6356.       Y12I= X12I( J)
  6357.       Y22R= X22R( J)
  6358.       Y22I= X22I( J)
  6359.       GOTO 17
  6360.    16 Y22R= TP* X11I( J)/ WLAM
  6361.       Y12R=0.
  6362.       Y12I=1./( X11R( J)* SIN( Y22R))
  6363.       Y11R= X12R( J)
  6364.       Y11I=- Y12I* COS( Y22R)
  6365.       Y22R= X22R( J)
  6366.       Y22I= Y11I+ X22I( J)
  6367.       Y11I= Y11I+ X12I( J)
  6368.       IF( NTYP( J).EQ.2) GOTO 17
  6369.       Y12R=- Y12R
  6370.       Y12I=- Y12I
  6371.    17 IF( NSANT.EQ.0) GOTO 19
  6372.       DO 18  I=1, NSANT
  6373.       IF( NSEG1.NE. ISANT( I)) GOTO 18
  6374.       ISC1= I
  6375.       GOTO 22
  6376.    18 CONTINUE
  6377.    19 ISC1=0
  6378.       IF( NTEQ.EQ.0) GOTO 21
  6379.       DO 20  I=1, NTEQ
  6380.       IF( NSEG1.NE. NTEQA( I)) GOTO 20
  6381.       IROW1= I
  6382.       GOTO 25
  6383.    20 CONTINUE
  6384.    21 NTEQ= NTEQ+1
  6385.       IROW1= NTEQ
  6386.       NTEQA( NTEQ)= NSEG1
  6387.       GOTO 25
  6388.    22 IF( NTSC.EQ.0) GOTO 24
  6389.       DO 23  I=1, NTSC
  6390.       IF( NSEG1.NE. NTSCA( I)) GOTO 23
  6391.       IROW1= NDIMNP- I
  6392.       GOTO 25
  6393.    23 CONTINUE
  6394.    24 NTSC= NTSC+1
  6395.       IROW1= NDIMNP- NTSC
  6396.       NTSCA( NTSC)= NSEG1
  6397.       VSRC( NTSC)= VSANT( ISC1)
  6398.    25 IF( NSANT.EQ.0) GOTO 27
  6399.       DO 26  I=1, NSANT
  6400.       IF( NSEG2.NE. ISANT( I)) GOTO 26
  6401.       ISC2= I
  6402.       GOTO 30
  6403.    26 CONTINUE
  6404.    27 ISC2=0
  6405.       IF( NTEQ.EQ.0) GOTO 29
  6406.       DO 28  I=1, NTEQ
  6407.       IF( NSEG2.NE. NTEQA( I)) GOTO 28
  6408.       IROW2= I
  6409.       GOTO 33
  6410.    28 CONTINUE
  6411.    29 NTEQ= NTEQ+1
  6412.       IROW2= NTEQ
  6413.       NTEQA( NTEQ)= NSEG2
  6414.       GOTO 33
  6415.    30 IF( NTSC.EQ.0) GOTO 32
  6416.       DO 31  I=1, NTSC
  6417.       IF( NSEG2.NE. NTSCA( I)) GOTO 31
  6418.       IROW2= NDIMNP- I
  6419.       GOTO 33
  6420.    31 CONTINUE
  6421.    32 NTSC= NTSC+1
  6422.       IROW2= NDIMNP- NTSC
  6423.       NTSCA( NTSC)= NSEG2
  6424.       VSRC( NTSC)= VSANT( ISC2)
  6425.    33 IF( NTSC+ NTEQ.LT. NDIMNP) GOTO 34
  6426.       WRITE( 6,59) 
  6427. C                                                                       
  6428. C     FILL NETWORK EQUATION MATRIX AND RIGHT HAND SIDE VECTOR WITH      
  6429. C     NETWORK SHORT-CIRCUIT ADMITTANCE MATRIX COEFFICIENTS.             
  6430. C                                                                       
  6431.       STOP
  6432.    34 IF( ISC1.NE.0) GOTO 35
  6433.       CMN( IROW1, IROW1)= CMN( IROW1, IROW1)- CMPLX( Y11R, Y11I)* SI( 
  6434.      &NSEG1)
  6435.       CMN( IROW1, IROW2)= CMN( IROW1, IROW2)- CMPLX( Y12R, Y12I)* SI( 
  6436.      &NSEG1)
  6437.       GOTO 36
  6438.    35 RHNX( IROW1)= RHNX( IROW1)+ CMPLX( Y11R, Y11I)* VSANT( ISC1)/ 
  6439.      &WLAM
  6440.       RHNX( IROW2)= RHNX( IROW2)+ CMPLX( Y12R, Y12I)* VSANT( ISC1)/ 
  6441.      &WLAM
  6442.    36 IF( ISC2.NE.0) GOTO 37
  6443.       CMN( IROW2, IROW2)= CMN( IROW2, IROW2)- CMPLX( Y22R, Y22I)* SI( 
  6444.      &NSEG2)
  6445.       CMN( IROW2, IROW1)= CMN( IROW2, IROW1)- CMPLX( Y12R, Y12I)* SI( 
  6446.      &NSEG2)
  6447.       GOTO 38
  6448.    37 RHNX( IROW1)= RHNX( IROW1)+ CMPLX( Y12R, Y12I)* VSANT( ISC2)/ 
  6449.      &WLAM
  6450.       RHNX( IROW2)= RHNX( IROW2)+ CMPLX( Y22R, Y22I)* VSANT( ISC2)/ 
  6451.      &WLAM
  6452. C                                                                       
  6453. C     ADD INTERACTION MATRIX ADMITTANCE ELEMENTS TO NETWORK EQUATION    
  6454. C     MATRIX                                                            
  6455. C                                                                       
  6456.    38 CONTINUE
  6457.       DO 41  I=1, NTEQ
  6458.       DO 39  J=1, NEQT
  6459.    39 RHS( J)=(0.,0.)
  6460.       IROW1= NTEQA( I)
  6461.       RHS( IROW1)=(1.,0.)
  6462.       CALL SOLGF( CM, CMB, CMC, CMD, RHS, IP, NP, N1, N, MP, M1, M, NEQ
  6463.      &, NEQ2, NEQZ2)
  6464.       CALL CABC( RHS)
  6465.       DO 40  J=1, NTEQ
  6466.       IROW1= NTEQA( J)
  6467.    40 CMN( I, J)= CMN( I, J)+ RHS( IROW1)
  6468. C                                                                       
  6469. C     FACTOR NETWORK EQUATION MATRIX                                    
  6470. C                                                                       
  6471.    41 CONTINUE
  6472. C                                                                       
  6473. C     ADD TO NETWORK EQUATION RIGHT HAND SIDE THE TERMS DUE TO ELEMENT  
  6474. C     INTERACTIONS                                                      
  6475. C                                                                       
  6476.       CALL FACTR( NTEQ, CMN, IPNT, NDIMN)
  6477.    42 IF( NONET.EQ.0) GOTO 48
  6478.       DO 43  I=1, NEQT
  6479.    43 RHS( I)= EINC( I)
  6480.       CALL SOLGF( CM, CMB, CMC, CMD, RHS, IP, NP, N1, N, MP, M1, M, NEQ
  6481.      &, NEQ2, NEQZ2)
  6482.       CALL CABC( RHS)
  6483.       DO 44  I=1, NTEQ
  6484.       IROW1= NTEQA( I)
  6485. C                                                                       
  6486. C     SOLVE NETWORK EQUATIONS                                           
  6487. C                                                                       
  6488.    44 RHNT( I)= RHNX( I)+ RHS( IROW1)
  6489. C                                                                       
  6490. C     ADD FIELDS DUE TO NETWORK VOLTAGES TO ELECTRIC FIELDS APPLIED TO  
  6491. C     STRUCTURE AND SOLVE FOR INDUCED CURRENT                           
  6492. C                                                                       
  6493.       CALL SOLVE( NTEQ, CMN, IPNT, RHNT, NDIMN)
  6494.       DO 45  I=1, NTEQ
  6495.       IROW1= NTEQA( I)
  6496.    45 EINC( IROW1)= EINC( IROW1)- RHNT( I)
  6497.       CALL SOLGF( CM, CMB, CMC, CMD, EINC, IP, NP, N1, N, MP, M1, M, 
  6498.      &NEQ, NEQ2, NEQZ2)
  6499.       CALL CABC( EINC)
  6500.       IF( NPRINT.EQ.0) WRITE( 6,61) 
  6501.       IF( NPRINT.EQ.0) WRITE( 6,60) 
  6502.       DO 46  I=1, NTEQ
  6503.       IROW1= NTEQA( I)
  6504.       VLT= RHNT( I)* SI( IROW1)* WLAM
  6505.       CUX= EINC( IROW1)* WLAM
  6506.       YMIT= CUX/ VLT
  6507.       ZPED= VLT/ CUX
  6508.       IROW2= ITAG( IROW1)
  6509.       PWR=.5* REAL( VLT* CONJG( CUX))
  6510.       PNLS= PNLS- PWR
  6511.    46 IF( NPRINT.EQ.0) WRITE( 6,62)  IROW2, IROW1, VLT, CUX, ZPED, YMIT
  6512.      &, PWR
  6513.       IF( NTSC.EQ.0) GOTO 49
  6514.       DO 47  I=1, NTSC
  6515.       IROW1= NTSCA( I)
  6516.       VLT= VSRC( I)
  6517.       CUX= EINC( IROW1)* WLAM
  6518.       YMIT= CUX/ VLT
  6519.       ZPED= VLT/ CUX
  6520.       IROW2= ITAG( IROW1)
  6521.       PWR=.5* REAL( VLT* CONJG( CUX))
  6522.       PNLS= PNLS- PWR
  6523.    47 IF( NPRINT.EQ.0) WRITE( 6,62)  IROW2, IROW1, VLT, CUX, ZPED, YMIT
  6524.      &, PWR
  6525. C                                                                       
  6526. C     SOLVE FOR CURRENTS WHEN NO NETWORKS ARE PRESENT                   
  6527. C                                                                       
  6528.       GOTO 49
  6529.    48 CALL SOLGF( CM, CMB, CMC, CMD, EINC, IP, NP, N1, N, MP, M1, M, 
  6530.      &NEQ, NEQ2, NEQZ2)
  6531.       CALL CABC( EINC)
  6532.       NTSC=0
  6533.    49 IF( NSANT+ NVQD.EQ.0) RETURN
  6534.       WRITE( 6,63) 
  6535.       WRITE( 6,60) 
  6536.       IF( NSANT.EQ.0) GOTO 56
  6537.       DO 55  I=1, NSANT
  6538.       ISC1= ISANT( I)
  6539.       VLT= VSANT( I)
  6540.       IF( NTSC.EQ.0) GOTO 51
  6541.       DO 50  J=1, NTSC
  6542.       IF( NTSCA( J).EQ. ISC1) GOTO 52
  6543.    50 CONTINUE
  6544.    51 CUX= EINC( ISC1)* WLAM
  6545.       IROW1=0
  6546.       GOTO 54
  6547.    52 IROW1= NDIMNP- J
  6548.       CUX= RHNX( IROW1)
  6549.       DO 53  J=1, NTEQ
  6550.    53 CUX= CUX- CMN( J, IROW1)* RHNT( J)
  6551.       CUX=( EINC( ISC1)+ CUX)* WLAM
  6552.    54 YMIT= CUX/ VLT
  6553.       ZPED= VLT/ CUX
  6554.       PWR=.5* REAL( VLT* CONJG( CUX))
  6555.       PIN= PIN+ PWR
  6556.       IF( IROW1.NE.0) PNLS= PNLS+ PWR
  6557.       IROW2= ITAG( ISC1)
  6558.    55 WRITE( 6,62)  IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR
  6559.    56 IF( NVQD.EQ.0) RETURN
  6560.       DO 57  I=1, NVQD
  6561.       ISC1= IVQD( I)
  6562.       VLT= VQD( I)
  6563.       CUX= CMPLX( AIR( ISC1), AII( ISC1))
  6564.       YMIT= CMPLX( BIR( ISC1), BII( ISC1))
  6565.       ZPED= CMPLX( CIR( ISC1), CII( ISC1))
  6566.       PWR= SI( ISC1)* TP*.5
  6567.       CUX=( CUX- YMIT* SIN( PWR)+ ZPED* COS( PWR))* WLAM
  6568.       YMIT= CUX/ VLT
  6569.       ZPED= VLT/ CUX
  6570.       PWR=.5* REAL( VLT* CONJG( CUX))
  6571.       PIN= PIN+ PWR
  6572.       IROW2= ITAG( ISC1)
  6573.    57 WRITE( 6,64)  IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR
  6574. C                                                                       
  6575.       RETURN
  6576.    58 FORMAT(///,3X,'MAXIMUM RELATIVE ASYMMETRY OF THE DRIVING POINT',
  6577.      &' ADMITTANCE MATRIX IS',1P,E10.3,' FOR SEGMENTS',I5,4H AND,I5,/,3
  6578.      &X,'RMS RELATIVE ASYMMETRY IS',E10.3)
  6579.    59 FORMAT(1X,'ERROR - - NETWORK ARRAY DIMENSIONS TOO SMALL')
  6580.    60 FORMAT(/,3X,'TAG',3X,'SEG.',4X,'VOLTAGE (VOLTS)',9X,'CURRENT (',
  6581.      &'AMPS)',9X,'IMPEDANCE (OHMS)',8X,'ADMITTANCE (MHOS)',6X,'POWER',/
  6582.      &,3X,'NO.',3X,'NO.',4X,'REAL',8X,'IMAG.',3(7X,'REAL',8X,'IMAG.'),5
  6583.      &X,'(WATTS)')
  6584.    61 FORMAT(///,27X,'- - - STRUCTURE EXCITATION DATA AT NETWORK CONN',
  6585.      &'ECTION POINTS - - -')
  6586.    62 FORMAT(2(1X,I5),1P,9E12.5)
  6587.    63 FORMAT(///,42X,'- - - ANTENNA INPUT PARAMETERS - - -')
  6588.    64 FORMAT(1X,I5,' *',I4,1P,9E12.5)
  6589.       END
  6590. C ***
  6591. C     DOUBLE PRECISION 6/4/85
  6592. C
  6593.       SUBROUTINE NFPAT
  6594. C ***
  6595. C     COMPUTE NEAR E OR H FIELDS OVER A RANGE OF POINTS                 
  6596.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  6597.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  6598.       COMPLEX  EX, EY, EZ
  6599.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  6600.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  6601.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  6602. C***
  6603.       COMMON  /FPAT/ THETS, PHIS, DTH, DPH, RFLD, GNOR, CLT, CHT, EPSR2,
  6604.      & SIG2, XPR6, PINR, PNLR, PLOSS, XNR, YNR, ZNR, DXNR, DYNR, DZNR,
  6605.      &NTH, NPH, IPD, IAVP, INOR, IAX, IXTYP, NEAR, NFEH, NRX, NRY, NRZ 
  6606. C***
  6607.       COMMON  /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
  6608.       DATA   TA/1.745329252D-02/
  6609.       IF( NFEH.EQ.1) GOTO 1
  6610.       WRITE( 6,10) 
  6611.       GOTO 2
  6612.     1 WRITE( 6,12) 
  6613.     2 ZNRT= ZNR- DZNR
  6614.       DO 9  I=1, NRZ
  6615.       ZNRT= ZNRT+ DZNR
  6616.       IF( NEAR.EQ.0) GOTO 3
  6617.       CTH= COS( TA* ZNRT)
  6618.       STH= SIN( TA* ZNRT)
  6619.     3 YNRT= YNR- DYNR
  6620.       DO 9  J=1, NRY
  6621.       YNRT= YNRT+ DYNR
  6622.       IF( NEAR.EQ.0) GOTO 4
  6623.       CPH= COS( TA* YNRT)
  6624.       SPH= SIN( TA* YNRT)
  6625.     4 XNRT= XNR- DXNR
  6626.       DO 9  KK=1, NRX
  6627.       XNRT= XNRT+ DXNR
  6628.       IF( NEAR.EQ.0) GOTO 5
  6629.       XOB= XNRT* STH* CPH
  6630.       YOB= XNRT* STH* SPH
  6631.       ZOB= XNRT* CTH
  6632.       GOTO 6
  6633.     5 XOB= XNRT
  6634.       YOB= YNRT
  6635.       ZOB= ZNRT
  6636.     6 TMP1= XOB/ WLAM
  6637.       TMP2= YOB/ WLAM
  6638.       TMP3= ZOB/ WLAM
  6639.       IF( NFEH.EQ.1) GOTO 7
  6640.       CALL NEFLD( TMP1, TMP2, TMP3, EX, EY, EZ)
  6641.       GOTO 8
  6642.     7 CALL NHFLD( TMP1, TMP2, TMP3, EX, EY, EZ)
  6643.     8 TMP1= ABS( EX)
  6644.       TMP2= CANG( EX)
  6645.       TMP3= ABS( EY)
  6646.       TMP4= CANG( EY)
  6647.       TMP5= ABS( EZ)
  6648.       TMP6= CANG( EZ)
  6649. C***
  6650.       WRITE( 6,11)  XOB, YOB, ZOB, TMP1, TMP2, TMP3, TMP4, TMP5, TMP6
  6651.       IF( IPLP1.NE.2) GOTO 9
  6652.       GOTO (14,15,16), IPLP4
  6653.    14 XXX= XOB
  6654.       GOTO 17
  6655.    15 XXX= YOB
  6656.       GOTO 17
  6657.    16 XXX= ZOB
  6658.    17 CONTINUE
  6659.       IF( IPLP2.NE.2) GOTO 13
  6660.       IF( IPLP3.EQ.1) WRITE( 8,*)  XXX, TMP1, TMP2
  6661.       IF( IPLP3.EQ.2) WRITE( 8,*)  XXX, TMP3, TMP4
  6662.       IF( IPLP3.EQ.3) WRITE( 8,*)  XXX, TMP5, TMP6
  6663.       IF( IPLP3.EQ.4) WRITE( 8,*)  XXX, TMP1, TMP2, TMP3, TMP4, TMP5, 
  6664.      &TMP6
  6665.       GOTO 9
  6666.    13 IF( IPLP2.NE.1) GOTO 9
  6667.       IF( IPLP3.EQ.1) WRITE( 8,*)  XXX, EX
  6668.       IF( IPLP3.EQ.2) WRITE( 8,*)  XXX, EY
  6669.       IF( IPLP3.EQ.3) WRITE( 8,*)  XXX, EZ
  6670. C***
  6671.       IF( IPLP3.EQ.4) WRITE( 8,*)  XXX, EX, EY, EZ
  6672.     9 CONTINUE
  6673. C                                                                       
  6674.       RETURN
  6675.    10 FORMAT(///,35X,'- - - NEAR ELECTRIC FIELDS - - -',//,12X,'-  L',
  6676.      &'OCATION  -',21X,'-  EX  -',15X,'-  EY  -',15X,'-  EZ  -',/,8X,
  6677.      &'X',10X,'Y',10X,'Z',10X,'MAGNITUDE',3X,'PHASE',6X,'MAGNITUDE',3X,
  6678.      &'PHASE',6X,'MAGNITUDE',3X,'PHASE',/,6X,'METERS',5X,'METERS',5X,
  6679.      &'METERS',8X,'VOLTS/M',3X,'DEGREES',6X,'VOLTS/M',3X,'DEGREES',6X
  6680.      &,'VOLTS/M',3X,'DEGREES')
  6681.    11 FORMAT(2X,3(2X,F9.4),1X,3(3X,1P,E11.4,2X,0P,F7.2))
  6682.    12 FORMAT(///,35X,'- - - NEAR MAGNETIC FIELDS - - -',//,12X,'-  L',
  6683.      &'OCATION  -',21X,'-  HX  -',15X,'-  HY  -',15X,'-  HZ  -',/,8X,
  6684.      &'X',10X,'Y',10X,'Z',10X,'MAGNITUDE',3X,'PHASE',6X,'MAGNITUDE',3X,
  6685.      &'PHASE',6X,'MAGNITUDE',3X,'PHASE',/,6X,'METERS',5X,'METERS',5X,
  6686.      &'METERS',9X,'AMPS/M',3X,'DEGREES',7X,'AMPS/M',3X,'DEGREES',7X,
  6687.      &'AMPS/M',3X,'DEGREES')
  6688.       END
  6689. C ***
  6690. C     DOUBLE PRECISION 6/4/85
  6691. C
  6692.       SUBROUTINE NHFLD( XOB, YOB, ZOB, HX, HY, HZ)
  6693. C ***
  6694. C                                                                       
  6695. C     NHFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER  
  6696. C     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.                        
  6697. C                                                                       
  6698.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  6699.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  6700.       COMPLEXHX,HY,HZ,CUR,ACX,  BCX, CCX, EXK, EYK, EZK, EXS, EYS, 
  6701.      &EZS, EXC, EYC, EZC
  6702.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  6703.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  6704.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  6705.       COMMON  /ANGL/ SALP( NM)
  6706.       COMMON  /CRNT/ AIR( NM), AII( NM), BIR( NM), BII( NM), CIR( NM), 
  6707.      &CII( NM), CUR( N3M)
  6708.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  6709.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  6710.      &INDD2, IPGND
  6711.       DIMENSION  CAB(1), SAB(1)
  6712.       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), XS(1),
  6713.      & YS(1), ZS(1)
  6714.       EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
  6715.      &T2Z,ITAG),(XS,X),(YS,Y),(ZS,Z)
  6716.       EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
  6717.      &IND1),(T2ZJ,IND2)
  6718.       EQUIVALENCE(CAB,ALP),(SAB,BET)
  6719.       HX=(0.,0.)
  6720.       HY=(0.,0.)
  6721.       HZ=(0.,0.)
  6722.       AX=0.
  6723.       IF( N.EQ.0) GOTO 4
  6724.       DO 1  I=1, N
  6725.       XJ= XOB- X( I)
  6726.       YJ= YOB- Y( I)
  6727.       ZJ= ZOB- Z( I)
  6728.       ZP= CAB( I)* XJ+ SAB( I)* YJ+ SALP( I)* ZJ
  6729.       IF( ABS( ZP).GT.0.5001* SI( I)) GOTO 1
  6730.       ZP= XJ* XJ+ YJ* YJ+ ZJ* ZJ- ZP* ZP
  6731.       XJ= BI( I)
  6732.       IF( ZP.GT.0.9* XJ* XJ) GOTO 1
  6733.       AX= XJ
  6734.       GOTO 2
  6735.     1 CONTINUE
  6736.     2 DO 3  I=1, N
  6737.       S= SI( I)
  6738.       B= BI( I)
  6739.       XJ= X( I)
  6740.       YJ= Y( I)
  6741.       ZJ= Z( I)
  6742.       CABJ= CAB( I)
  6743.       SABJ= SAB( I)
  6744.       SALPJ= SALP( I)
  6745.       CALL HSFLD( XOB, YOB, ZOB, AX)
  6746.       ACX= CMPLX( AIR( I), AII( I))
  6747.       BCX= CMPLX( BIR( I), BII( I))
  6748.       CCX= CMPLX( CIR( I), CII( I))
  6749.       HX= HX+ EXK* ACX+ EXS* BCX+ EXC* CCX
  6750.       HY= HY+ EYK* ACX+ EYS* BCX+ EYC* CCX
  6751.     3 HZ= HZ+ EZK* ACX+ EZS* BCX+ EZC* CCX
  6752.       IF( M.EQ.0) RETURN
  6753.     4 JC= N
  6754.       JL= LD+1
  6755.       DO 5  I=1, M
  6756.       JL= JL-1
  6757.       S= BI( JL)
  6758.       XJ= X( JL)
  6759.       YJ= Y( JL)
  6760.       ZJ= Z( JL)
  6761.       T1XJ= T1X( JL)
  6762.       T1YJ= T1Y( JL)
  6763.       T1ZJ= T1Z( JL)
  6764.       T2XJ= T2X( JL)
  6765.       T2YJ= T2Y( JL)
  6766.       T2ZJ= T2Z( JL)
  6767.       CALL HINTG( XOB, YOB, ZOB)
  6768.       JC= JC+3
  6769.       ACX= T1XJ* CUR( JC-2)+ T1YJ* CUR( JC-1)+ T1ZJ* CUR( JC)
  6770.       BCX= T2XJ* CUR( JC-2)+ T2YJ* CUR( JC-1)+ T2ZJ* CUR( JC)
  6771.       HX= HX+ ACX* EXK+ BCX* EXS
  6772.       HY= HY+ ACX* EYK+ BCX* EYS
  6773.     5 HZ= HZ+ ACX* EZK+ BCX* EZS
  6774.       RETURN
  6775.       END
  6776. C ***
  6777. C     DOUBLE PRECISION 6/4/85
  6778. C
  6779.       SUBROUTINE PATCH( NX, NY, X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3, X4,
  6780.      & Y4, Z4)
  6781. C ***
  6782. C     PATCH GENERATES AND MODIFIES PATCH GEOMETRY DATA                  
  6783.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  6784.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  6785.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  6786.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  6787.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  6788.       COMMON  /ANGL/ SALP( NM)
  6789.       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  6790. C     NEW PATCHES.  FOR NX=0, NY=1,2,3,4 PATCH IS (RESPECTIVELY)        
  6791. C     ARBITRARY, RECTAGULAR, TRIANGULAR, OR QUADRILATERAL.              
  6792. C     FOR NX AND NY .GT. 0 A RECTANGULAR SURFACE IS PRODUCED WITH       
  6793. C     NX BY NY RECTANGULAR PATCHES.                                     
  6794.       EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
  6795.      &T2Z,ITAG)
  6796.       M= M+1
  6797.       MI= LD+1- M
  6798.       NTP= NY
  6799.       IF( NX.GT.0) NTP=2
  6800.       IF( NTP.GT.1) GOTO 2
  6801.       X( MI)= X1
  6802.       Y( MI)= Y1
  6803.       Z( MI)= Z1
  6804.       BI( MI)= Z2
  6805.       ZNV= COS( X2)
  6806.       XNV= ZNV* COS( Y2)
  6807.       YNV= ZNV* SIN( Y2)
  6808.       ZNV= SIN( X2)
  6809.       XA= SQRT( XNV* XNV+ YNV* YNV)
  6810.       IF( XA.LT.1.D-6) GOTO 1
  6811.       T1X( MI)=- YNV/ XA
  6812.       T1Y( MI)= XNV/ XA
  6813.       T1Z( MI)=0.
  6814.       GOTO 6
  6815.     1 T1X( MI)=1.
  6816.       T1Y( MI)=0.
  6817.       T1Z( MI)=0.
  6818.       GOTO 6
  6819.     2 S1X= X2- X1
  6820.       S1Y= Y2- Y1
  6821.       S1Z= Z2- Z1
  6822.       S2X= X3- X2
  6823.       S2Y= Y3- Y2
  6824.       S2Z= Z3- Z2
  6825.       IF( NX.EQ.0) GOTO 3
  6826.       S1X= S1X/ NX
  6827.       S1Y= S1Y/ NX
  6828.       S1Z= S1Z/ NX
  6829.       S2X= S2X/ NY
  6830.       S2Y= S2Y/ NY
  6831.       S2Z= S2Z/ NY
  6832.     3 XNV= S1Y* S2Z- S1Z* S2Y
  6833.       YNV= S1Z* S2X- S1X* S2Z
  6834.       ZNV= S1X* S2Y- S1Y* S2X
  6835.       XA= SQRT( XNV* XNV+ YNV* YNV+ ZNV* ZNV)
  6836.       XNV= XNV/ XA
  6837.       YNV= YNV/ XA
  6838.       ZNV= ZNV/ XA
  6839.       XST= SQRT( S1X* S1X+ S1Y* S1Y+ S1Z* S1Z)
  6840.       T1X( MI)= S1X/ XST
  6841.       T1Y( MI)= S1Y/ XST
  6842.       T1Z( MI)= S1Z/ XST
  6843.       IF( NTP.GT.2) GOTO 4
  6844.       X( MI)= X1+.5*( S1X+ S2X)
  6845.       Y( MI)= Y1+.5*( S1Y+ S2Y)
  6846.       Z( MI)= Z1+.5*( S1Z+ S2Z)
  6847.       BI( MI)= XA
  6848.       GOTO 6
  6849.     4 IF( NTP.EQ.4) GOTO 5
  6850.       X( MI)=( X1+ X2+ X3)/3.
  6851.       Y( MI)=( Y1+ Y2+ Y3)/3.
  6852.       Z( MI)=( Z1+ Z2+ Z3)/3.
  6853.       BI( MI)=.5* XA
  6854.       GOTO 6
  6855.     5 S1X= X3- X1
  6856.       S1Y= Y3- Y1
  6857.       S1Z= Z3- Z1
  6858.       S2X= X4- X1
  6859.       S2Y= Y4- Y1
  6860.       S2Z= Z4- Z1
  6861.       XN2= S1Y* S2Z- S1Z* S2Y
  6862.       YN2= S1Z* S2X- S1X* S2Z
  6863.       ZN2= S1X* S2Y- S1Y* S2X
  6864.       XST= SQRT( XN2* XN2+ YN2* YN2+ ZN2* ZN2)
  6865.       SALPN=1./(3.*( XA+ XST))
  6866.       X( MI)=( XA*( X1+ X2+ X3)+ XST*( X1+ X3+ X4))* SALPN
  6867.       Y( MI)=( XA*( Y1+ Y2+ Y3)+ XST*( Y1+ Y3+ Y4))* SALPN
  6868.       Z( MI)=( XA*( Z1+ Z2+ Z3)+ XST*( Z1+ Z3+ Z4))* SALPN
  6869.       BI( MI)=.5*( XA+ XST)
  6870.       S1X=( XNV* XN2+ YNV* YN2+ ZNV* ZN2)/ XST
  6871.       IF( S1X.GT.0.9998) GOTO 6
  6872.       WRITE( 6,14) 
  6873.       STOP
  6874.     6 T2X( MI)= YNV* T1Z( MI)- ZNV* T1Y( MI)
  6875.       T2Y( MI)= ZNV* T1X( MI)- XNV* T1Z( MI)
  6876.       T2Z( MI)= XNV* T1Y( MI)- YNV* T1X( MI)
  6877.       SALP( MI)=1.
  6878.       IF( NX.EQ.0) GOTO 8
  6879.       M= M+ NX* NY-1
  6880.       XN2= X( MI)- S1X- S2X
  6881.       YN2= Y( MI)- S1Y- S2Y
  6882.       ZN2= Z( MI)- S1Z- S2Z
  6883.       XS= T1X( MI)
  6884.       YS= T1Y( MI)
  6885.       ZS= T1Z( MI)
  6886.       XT= T2X( MI)
  6887.       YT= T2Y( MI)
  6888.       ZT= T2Z( MI)
  6889.       MI= MI+1
  6890.       DO 7  IY=1, NY
  6891.       XN2= XN2+ S2X
  6892.       YN2= YN2+ S2Y
  6893.       ZN2= ZN2+ S2Z
  6894.       DO 7  IX=1, NX
  6895.       XST= IX
  6896.       MI= MI-1
  6897.       X( MI)= XN2+ XST* S1X
  6898.       Y( MI)= YN2+ XST* S1Y
  6899.       Z( MI)= ZN2+ XST* S1Z
  6900.       BI( MI)= XA
  6901.       SALP( MI)=1.
  6902.       T1X( MI)= XS
  6903.       T1Y( MI)= YS
  6904.       T1Z( MI)= ZS
  6905.       T2X( MI)= XT
  6906.       T2Y( MI)= YT
  6907.     7 T2Z( MI)= ZT
  6908.     8 IPSYM=0
  6909.       NP= N
  6910.       MP= M
  6911. C     DIVIDE PATCH FOR WIRE CONNECTION                                  
  6912.       RETURN
  6913.       ENTRY SUBPH( NX, NY, X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3, X4, Y4, 
  6914.      &Z4)
  6915.       IF( NY.GT.0) GOTO 10
  6916.       IF( NX.EQ. M) GOTO 10
  6917.       NXP= NX+1
  6918.       IX= LD- M
  6919.       DO 9  IY= NXP, M
  6920.       IX= IX+1
  6921.       NYP= IX-3
  6922.       X( NYP)= X( IX)
  6923.       Y( NYP)= Y( IX)
  6924.       Z( NYP)= Z( IX)
  6925.       BI( NYP)= BI( IX)
  6926.       SALP( NYP)= SALP( IX)
  6927.       T1X( NYP)= T1X( IX)
  6928.       T1Y( NYP)= T1Y( IX)
  6929.       T1Z( NYP)= T1Z( IX)
  6930.       T2X( NYP)= T2X( IX)
  6931.       T2Y( NYP)= T2Y( IX)
  6932.     9 T2Z( NYP)= T2Z( IX)
  6933.    10 MI= LD+1- NX
  6934.       XS= X( MI)
  6935.       YS= Y( MI)
  6936.       ZS= Z( MI)
  6937.       XA= BI( MI)*.25
  6938.       XST= SQRT( XA)*.5
  6939.       S1X= T1X( MI)
  6940.       S1Y= T1Y( MI)
  6941.       S1Z= T1Z( MI)
  6942.       S2X= T2X( MI)
  6943.       S2Y= T2Y( MI)
  6944.       S2Z= T2Z( MI)
  6945.       SALN= SALP( MI)
  6946.       XT= XST
  6947.       YT= XST
  6948.       IF( NY.GT.0) GOTO 11
  6949.       MIA= MI
  6950.       GOTO 12
  6951.    11 M= M+1
  6952.       MP= MP+1
  6953.       MIA= LD+1- M
  6954.    12 DO 13  IX=1,4
  6955.       X( MIA)= XS+ XT* S1X+ YT* S2X
  6956.       Y( MIA)= YS+ XT* S1Y+ YT* S2Y
  6957.       Z( MIA)= ZS+ XT* S1Z+ YT* S2Z
  6958.       BI( MIA)= XA
  6959.       T1X( MIA)= S1X
  6960.       T1Y( MIA)= S1Y
  6961.       T1Z( MIA)= S1Z
  6962.       T2X( MIA)= S2X
  6963.       T2Y( MIA)= S2Y
  6964.       T2Z( MIA)= S2Z
  6965.       SALP( MIA)= SALN
  6966.       IF( IX.EQ.2) YT=- YT
  6967.       IF( IX.EQ.1.OR. IX.EQ.3) XT=- XT
  6968.       MIA= MIA-1
  6969.    13 CONTINUE
  6970.       M= M+3
  6971.       IF( NX.LE. MP) MP= MP+3
  6972.       IF( NY.GT.0) Z( MI)=10000.
  6973. C                                                                       
  6974.       RETURN
  6975.    14 FORMAT(' ERROR -- CORNERS OF QUADRILATERAL PATCH DO NOT LIE IN ',
  6976.      &'A PLANE')
  6977.       END
  6978. C ***
  6979. C     DOUBLE PRECISION 6/4/85
  6980. C
  6981.       SUBROUTINE PCINT( XI, YI, ZI, CABI, SABI, SALPI, E)
  6982. C ***
  6983. C     INTEGRATE OVER PATCHES AT WIRE CONNECTION POINT                   
  6984.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  6985.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  6986.       COMPLEX  EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, E, E1, 
  6987.      &E2, E3, E4, E5, E6, E7, E8, E9
  6988.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  6989.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  6990.      &INDD2, IPGND
  6991.       DIMENSION  E(9)
  6992.       EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
  6993.      &IND1),(T2ZJ,IND2)
  6994.       DATA   TPI/6.283185308D+0/, NINT/10/
  6995.       D= SQRT( S)*.5
  6996.       DS=4.* D/ DFLOAT( NINT)
  6997.       DA= DS* DS
  6998.       GCON=1./ S
  6999.       FCON=1./(2.* TPI* D)
  7000.       XXJ= XJ
  7001.       XYJ= YJ
  7002.       XZJ= ZJ
  7003.       XS= S
  7004.       S= DA
  7005.       S1= D+ DS*.5
  7006.       XSS= XJ+ S1*( T1XJ+ T2XJ)
  7007.       YSS= YJ+ S1*( T1YJ+ T2YJ)
  7008.       ZSS= ZJ+ S1*( T1ZJ+ T2ZJ)
  7009.       S1= S1+ D
  7010.       S2X= S1
  7011.       E1=(0.,0.)
  7012.       E2=(0.,0.)
  7013.       E3=(0.,0.)
  7014.       E4=(0.,0.)
  7015.       E5=(0.,0.)
  7016.       E6=(0.,0.)
  7017.       E7=(0.,0.)
  7018.       E8=(0.,0.)
  7019.       E9=(0.,0.)
  7020.       DO 1  I1=1, NINT
  7021.       S1= S1- DS
  7022.       S2= S2X
  7023.       XSS= XSS- DS* T1XJ
  7024.       YSS= YSS- DS* T1YJ
  7025.       ZSS= ZSS- DS* T1ZJ
  7026.       XJ= XSS
  7027.       YJ= YSS
  7028.       ZJ= ZSS
  7029.       DO 1  I2=1, NINT
  7030.       S2= S2- DS
  7031.       XJ= XJ- DS* T2XJ
  7032.       YJ= YJ- DS* T2YJ
  7033.       ZJ= ZJ- DS* T2ZJ
  7034.       CALL UNERE( XI, YI, ZI)
  7035.       EXK= EXK* CABI+ EYK* SABI+ EZK* SALPI
  7036.       EXS= EXS* CABI+ EYS* SABI+ EZS* SALPI
  7037.       G1=( D+ S1)*( D+ S2)* GCON
  7038.       G2=( D- S1)*( D+ S2)* GCON
  7039.       G3=( D- S1)*( D- S2)* GCON
  7040.       G4=( D+ S1)*( D- S2)* GCON
  7041.       F2=( S1* S1+ S2* S2)* TPI
  7042.       F1= S1/ F2-( G1- G2- G3+ G4)* FCON
  7043.       F2= S2/ F2-( G1+ G2- G3- G4)* FCON
  7044.       E1= E1+ EXK* G1
  7045.       E2= E2+ EXK* G2
  7046.       E3= E3+ EXK* G3
  7047.       E4= E4+ EXK* G4
  7048.       E5= E5+ EXS* G1
  7049.       E6= E6+ EXS* G2
  7050.       E7= E7+ EXS* G3
  7051.       E8= E8+ EXS* G4
  7052.     1 E9= E9+ EXK* F1+ EXS* F2
  7053.       E(1)= E1
  7054.       E(2)= E2
  7055.       E(3)= E3
  7056.       E(4)= E4
  7057.       E(5)= E5
  7058.       E(6)= E6
  7059.       E(7)= E7
  7060.       E(8)= E8
  7061.       E(9)= E9
  7062.       XJ= XXJ
  7063.       YJ= XYJ
  7064.       ZJ= XZJ
  7065.       S= XS
  7066.       RETURN
  7067.       END
  7068. C ***
  7069. C     DOUBLE PRECISION 6/4/85
  7070. C
  7071.       SUBROUTINE PRNT( IN1, IN2, IN3, FL1, FL2, FL3, FL4, FL5, FL6, IA,
  7072.      & ICHAR)
  7073. C ***
  7074. C                                                                       
  7075. C     PRNT SETS UP THE PRINT FORMATS FOR IMPEDANCE LOADING              
  7076. C                                                                       
  7077.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  7078.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  7079. C     REAL  IFORM, IVAR
  7080.       CHARACTER*6 IFORM(8),IVAR(13)
  7081.       DIMENSION IA(1),IN(3),INT(3),FL(6),FLT(6)
  7082.       INTEGER  HALL
  7083. C                                                                       
  7084. C     NUMBER OF CHARACTERS PER COMPUTER WORD IS NCPW                    
  7085. C                                                                       
  7086.       DATA   IFORM/5H(/3X,,3HI5,,3H5X,,3HA5,,6HE13.4,,4H13X,,3H3X,,
  7087.      &4H5A4)/
  7088.       DATA   HALL/4H ALL/
  7089.       IN(1)= IN1
  7090.       IN(2)= IN2
  7091.       IN(3)= IN3
  7092.       FL(1)= FL1
  7093.       FL(2)= FL2
  7094.       FL(3)= FL3
  7095.       FL(4)= FL4
  7096.       FL(5)= FL5
  7097. C                                                                       
  7098. C     INTEGER FORMAT                                                    
  7099. C                                                                       
  7100.       FL(6)= FL6
  7101.       NINT=0
  7102.       IVAR(1)= IFORM(1)
  7103.       K=1
  7104.       I1=1
  7105.       IF(.NOT.( IN1.EQ.0.AND. IN2.EQ.0.AND. IN3.EQ.0)) GOTO 1
  7106.       INT(1)= HALL
  7107.       NINT=1
  7108.       I1=2
  7109.       K= K+1
  7110.       IVAR( K)= IFORM(4)
  7111.     1 DO 3  I= I1,3
  7112.       K= K+1
  7113.       IF( IN( I).EQ.0) GOTO 2
  7114.       NINT= NINT+1
  7115.       INT( NINT)= IN( I)
  7116.       IVAR( K)= IFORM(2)
  7117.       GOTO 3
  7118.     2 IVAR( K)= IFORM(3)
  7119.     3 CONTINUE
  7120.       K= K+1
  7121. C                                                                       
  7122. C     DFLOATING POINT FORMAT                                            
  7123. C                                                                       
  7124.       IVAR( K)= IFORM(7)
  7125.       NFLT=0
  7126.       DO 5  I=1,6
  7127.       K= K+1
  7128.       IF( ABS( FL( I)).LT.1.D-20) GOTO 4
  7129.       NFLT= NFLT+1
  7130.       FLT( NFLT)= FL( I)
  7131.       IVAR( K)= IFORM(5)
  7132.       GOTO 5
  7133.     4 IVAR( K)= IFORM(6)
  7134.     5 CONTINUE
  7135.       K= K+1
  7136.       IVAR( K)= IFORM(7)
  7137.       K= K+1
  7138.       IVAR( K)= IFORM(8)
  7139.       WRITE( 6,IVAR) ( INT( I), I=1, NINT),( FLT( J), J=1, NFLT),( IA( 
  7140.      &L), L=1, ICHAR)
  7141.       RETURN
  7142.       END
  7143. C ***
  7144. C     DOUBLE PRECISION 6/4/85
  7145. C
  7146.       SUBROUTINE QDSRC( IS, V, E)
  7147. C ***
  7148. C     FILL INCIDENT FIELD ARRAY FOR CHARGE DISCONTINUITY VOLTAGE SOURCE 
  7149.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  7150.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  7151.       COMPLEX  VQDS, CURD, CCJ, V, EXK, EYK, EZK, EXS, EYS, EZS, EXC
  7152.      &, EYC, EZC, ETK, ETS, ETC, VSANT, VQD, E, ZARRAY
  7153.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  7154.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  7155.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  7156.       COMMON  /VSORC/ VQD(30), VSANT(30), VQDS(30), IVQD(30), ISANT(30)
  7157.      &, IQDS(30), NVQD, NSANT, NQDS
  7158.       COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50), 
  7159.      &NSCON, IPCON(10), NPCON
  7160.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  7161.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  7162.      &INDD2, IPGND
  7163.       COMMON  /ANGL/ SALP( NM)
  7164.       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF
  7165.       DIMENSION  CCJX(2), E(1), CAB(1), SAB(1)
  7166.       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1)
  7167.       EQUIVALENCE(CCJ,CCJX),(CAB,ALP),(SAB,BET)
  7168.       EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
  7169.      &T2Z,ITAG)
  7170.       DATA   TP/6.283185308D+0/, CCJX/0.,-.01666666667D+0/
  7171.       I= ICON1( IS)
  7172.       ICON1( IS)=0
  7173.       CALL TBF( IS,0)
  7174.       ICON1( IS)= I
  7175.       S= SI( IS)*.5
  7176.       CURD= CCJ* V/(( LOG(2.* S/ BI( IS))-1.)*( BX( JSNO)* COS( TP* S)+
  7177.      & CX( JSNO)* SIN( TP* S))* WLAM)
  7178.       NQDS= NQDS+1
  7179.       VQDS( NQDS)= V
  7180.       IQDS( NQDS)= IS
  7181.       DO 20  JX=1, JSNO
  7182.       J= JCO( JX)
  7183.       S= SI( J)
  7184.       B= BI( J)
  7185.       XJ= X( J)
  7186.       YJ= Y( J)
  7187.       ZJ= Z( J)
  7188.       CABJ= CAB( J)
  7189.       SABJ= SAB( J)
  7190.       SALPJ= SALP( J)
  7191.       IF( IEXK.EQ.0) GOTO 16
  7192.       IPR= ICON1( J)
  7193.       IF( IPR) 1,6,2
  7194.     1 IPR=- IPR
  7195.       IF(- ICON1( IPR).NE. J) GOTO 7
  7196.       GOTO 4
  7197.     2 IF( IPR.NE. J) GOTO 3
  7198.       IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 7
  7199.       GOTO 5
  7200.     3 IF( ICON2( IPR).NE. J) GOTO 7
  7201.     4 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
  7202.       IF( XI.LT.0.999999D+0) GOTO 7
  7203.       IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 7
  7204.     5 IND1=0
  7205.       GOTO 8
  7206.     6 IND1=1
  7207.       GOTO 8
  7208.     7 IND1=2
  7209.     8 IPR= ICON2( J)
  7210.       IF( IPR) 9,14,10
  7211.     9 IPR=- IPR
  7212.       IF(- ICON2( IPR).NE. J) GOTO 15
  7213.       GOTO 12
  7214.    10 IF( IPR.NE. J) GOTO 11
  7215.       IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 15
  7216.       GOTO 13
  7217.    11 IF( ICON1( IPR).NE. J) GOTO 15
  7218.    12 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR))
  7219.       IF( XI.LT.0.999999D+0) GOTO 15
  7220.       IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 15
  7221.    13 IND2=0
  7222.       GOTO 16
  7223.    14 IND2=1
  7224.       GOTO 16
  7225.    15 IND2=2
  7226.    16 CONTINUE
  7227.       DO 17  I=1, N
  7228.       IJ= I- J
  7229.       XI= X( I)
  7230.       YI= Y( I)
  7231.       ZI= Z( I)
  7232.       AI= BI( I)
  7233.       CALL EFLD( XI, YI, ZI, AI, IJ)
  7234.       CABI= CAB( I)
  7235.       SABI= SAB( I)
  7236.       SALPI= SALP( I)
  7237.       ETK= EXK* CABI+ EYK* SABI+ EZK* SALPI
  7238.       ETS= EXS* CABI+ EYS* SABI+ EZS* SALPI
  7239.       ETC= EXC* CABI+ EYC* SABI+ EZC* SALPI
  7240.    17 E( I)= E( I)-( ETK* AX( JX)+ ETS* BX( JX)+ ETC* CX( JX))* CURD
  7241.       IF( M.EQ.0) GOTO 19
  7242.       IJ= LD+1
  7243.       I1= N
  7244.       DO 18  I=1, M
  7245.       IJ= IJ-1
  7246.       XI= X( IJ)
  7247.       YI= Y( IJ)
  7248.       ZI= Z( IJ)
  7249.       CALL HSFLD( XI, YI, ZI,0.)
  7250.       I1= I1+1
  7251.       TX= T2X( IJ)
  7252.       TY= T2Y( IJ)
  7253.       TZ= T2Z( IJ)
  7254.       ETK= EXK* TX+ EYK* TY+ EZK* TZ
  7255.       ETS= EXS* TX+ EYS* TY+ EZS* TZ
  7256.       ETC= EXC* TX+ EYC* TY+ EZC* TZ
  7257.       E( I1)= E( I1)+( ETK* AX( JX)+ ETS* BX( JX)+ ETC* CX( JX))* CURD*
  7258.      & SALP( IJ)
  7259.       I1= I1+1
  7260.       TX= T1X( IJ)
  7261.       TY= T1Y( IJ)
  7262.       TZ= T1Z( IJ)
  7263.       ETK= EXK* TX+ EYK* TY+ EZK* TZ
  7264.       ETS= EXS* TX+ EYS* TY+ EZS* TZ
  7265.       ETC= EXC* TX+ EYC* TY+ EZC* TZ
  7266.    18 E( I1)= E( I1)+( ETK* AX( JX)+ ETS* BX( JX)+ ETC* CX( JX))* CURD*
  7267.      & SALP( IJ)
  7268.    19 IF( NLOAD.GT.0.OR. NLODF.GT.0) E( J)= E( J)+ ZARRAY( J)* CURD*( 
  7269.      &AX( JX)+ CX( JX))
  7270.    20 CONTINUE
  7271.       RETURN
  7272.       END
  7273. C ***
  7274. C     DOUBLE PRECISION 6/4/85
  7275. C
  7276.       SUBROUTINE RDPAT
  7277. C ***
  7278. C     COMPUTE RADIATION PATTERN, GAIN, NORMALIZED GAIN                  
  7279.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  7280.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  7281. C     INTEGER HPOL,HBLK,HCIR,HCLIF                                      
  7282.       REAL  IGNTP, IGAX, IGTP, COM
  7283.       COMPLEX  ETH, EPH, ERD, ZRATI, ZRATI2, T1, FRATI
  7284.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  7285.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  7286.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  7287.       COMMON  /SAVE/COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(N2M),KCOM
  7288.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  7289.      &KSYMP, IFAR, IPERF, T1, T2
  7290.       COMMON  /FPAT/ THETS, PHIS, DTH, DPH, RFLD, GNOR, CLT, CHT, EPSR2,
  7291.      & SIG2, XPR6, PINR, PNLR, PLOSS, XNR, YNR, ZNR, DXNR, DYNR, DZNR,
  7292.      &NTH, NPH, IPD, IAVP, INOR, IAX, IXTYP, NEAR, NFEH, NRX, NRY, NRZ 
  7293. C***
  7294.       COMMON  /SCRATM/ GAIN(N2M)
  7295. C***
  7296.       COMMON  /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4
  7297.       DIMENSION  IGTP(4), IGAX(4), IGNTP(10)
  7298.       CHARACTER*6 HPOL(3),HCLIF,ISENS,HCIR,HBLK
  7299.       DATA   HBLK/6H      /
  7300.       DATA   HPOL/6HLINEAR,5HRIGHT,4HLEFT/, HCIR/6HCIRCLE/
  7301.       DATA   IGTP/6H    - ,6HPOWER ,6H- DIRE,6HCTIVE /
  7302.       DATA   IGAX/6H MAJOR,6H MINOR,6H VERT.,6H HOR. /
  7303.       DATA   IGNTP/6H MAJOR,6H AXIS ,6H MINOR,6H AXIS ,6H   VER,
  7304.      &6HTICAL ,6H HORIZ,6HONTAL ,6H      ,6HTOTAL /
  7305.       DATA   PI, TA, TD/3.141592654D+0,1.745329252D-02,57.29577951D+0/
  7306.       DATA   NORMAX/800/
  7307.       IF( IFAR.LT.2) GOTO 2
  7308.       WRITE( 6,35) 
  7309.       IF( IFAR.LE.3) GOTO 1
  7310.       WRITE( 6,36)  NRADL, SCRWLT, SCRWRT
  7311.       IF( IFAR.EQ.4) GOTO 2
  7312.     1 IF( IFAR.EQ.2.OR. IFAR.EQ.5) HCLIF= HPOL(1)
  7313.       IF( IFAR.EQ.3.OR. IFAR.EQ.6) HCLIF= HCIR
  7314.       CL= CLT/ WLAM
  7315.       CH= CHT/ WLAM
  7316.       ZRATI2= SQRT(1./ CMPLX( EPSR2,- SIG2* WLAM*59.96))
  7317.       WRITE( 6,37)  HCLIF, CLT, CHT, EPSR2, SIG2
  7318.     2 IF( IFAR.NE.1) GOTO 3
  7319.       WRITE( 6,41) 
  7320.       GOTO 5
  7321.     3 I=2* IPD+1
  7322.       J= I+1
  7323.       ITMP1=2* IAX+1
  7324.       ITMP2= ITMP1+1
  7325.       WRITE( 6,38) 
  7326.       IF( RFLD.LT.1.D-20) GOTO 4
  7327.       EXRM=1./ RFLD
  7328.       EXRA= RFLD/ WLAM
  7329.       EXRA=-360.*( EXRA- AINT( EXRA))
  7330.       WRITE( 6,39)  RFLD, EXRM, EXRA
  7331.     4 WRITE( 6,40)  IGTP( I), IGTP( J), IGAX( ITMP1), IGAX( ITMP2)
  7332.     5 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) GOTO 7
  7333.       IF( IXTYP.EQ.4) GOTO 6
  7334.       PRAD=0.
  7335.       GCON=4.* PI/(1.+ XPR6* XPR6)
  7336.       GCOP= GCON
  7337.       GOTO 8
  7338.     6 PINR=394.51* XPR6* XPR6* WLAM* WLAM
  7339.     7 GCOP= WLAM* WLAM*2.* PI/(376.73* PINR)
  7340.       PRAD= PINR- PLOSS- PNLR
  7341.       GCON= GCOP
  7342.       IF( IPD.NE.0) GCON= GCON* PINR/ PRAD
  7343.     8 I=0
  7344.       GMAX=-1.E10
  7345.       PINT=0.
  7346.       TMP1= DPH* TA
  7347.       TMP2=.5* DTH* TA
  7348.       PHI= PHIS- DPH
  7349.       DO 29  KPH=1, NPH
  7350.       PHI= PHI+ DPH
  7351.       PHA= PHI* TA
  7352.       THET= THETS- DTH
  7353.       DO 29  KTH=1, NTH
  7354.       THET= THET+ DTH
  7355.       IF( KSYMP.EQ.2.AND. THET.GT.90.01.AND. IFAR.NE.1) GOTO 29
  7356.       THA= THET* TA
  7357.       IF( IFAR.EQ.1) GOTO 9
  7358.       CALL FFLD( THA, PHA, ETH, EPH)
  7359.       GOTO 10
  7360.     9 CALL GFLD( RFLD/ WLAM, PHA, THET/ WLAM, ETH, EPH, ERD, ZRATI, 
  7361.      &KSYMP)
  7362.       ERDM= ABS( ERD)
  7363.       ERDA= CANG( ERD)
  7364.    10 ETHM2= REAL( ETH* CONJG( ETH))
  7365.       ETHM= SQRT( ETHM2)
  7366.       ETHA= CANG( ETH)
  7367.       EPHM2= REAL( EPH* CONJG( EPH))
  7368.       EPHM= SQRT( EPHM2)
  7369.       EPHA= CANG( EPH)
  7370. C     ELLIPTICAL POLARIZATION CALC.                                     
  7371.       IF( IFAR.EQ.1) GOTO 28
  7372.       IF( ETHM2.GT.1.D-20.OR. EPHM2.GT.1.D-20) GOTO 11
  7373.       TILTA=0.
  7374.       EMAJR2=0.
  7375.       EMINR2=0.
  7376.       AXRAT=0.
  7377.       ISENS= HBLK
  7378.       GOTO 16
  7379.    11 DFAZ= EPHA- ETHA
  7380.       IF( EPHA.LT.0.) GOTO 12
  7381.       DFAZ2= DFAZ-360.
  7382.       GOTO 13
  7383.    12 DFAZ2= DFAZ+360.
  7384.    13 IF( ABS( DFAZ).GT. ABS( DFAZ2)) DFAZ= DFAZ2
  7385.       CDFAZ= COS( DFAZ* TA)
  7386.       TSTOR1= ETHM2- EPHM2
  7387.       TSTOR2=2.* EPHM* ETHM* CDFAZ
  7388.       TILTA=.5* ATGN2( TSTOR2, TSTOR1)
  7389.       STILTA= SIN( TILTA)
  7390.       TSTOR1= TSTOR1* STILTA* STILTA
  7391.       TSTOR2= TSTOR2* STILTA* COS( TILTA)
  7392.       EMAJR2=- TSTOR1+ TSTOR2+ ETHM2
  7393.       EMINR2= TSTOR1- TSTOR2+ EPHM2
  7394.       IF( EMINR2.LT.0.) EMINR2=0.
  7395.       AXRAT= SQRT( EMINR2/ EMAJR2)
  7396.       TILTA= TILTA* TD
  7397.       IF( AXRAT.GT.1.D-5) GOTO 14
  7398.       ISENS= HPOL(1)
  7399.       GOTO 16
  7400.    14 IF( DFAZ.GT.0.) GOTO 15
  7401.       ISENS= HPOL(2)
  7402.       GOTO 16
  7403.    15 ISENS= HPOL(3)
  7404.    16 GNMJ= DB10( GCON* EMAJR2)
  7405.       GNMN= DB10( GCON* EMINR2)
  7406.       GNV= DB10( GCON* ETHM2)
  7407.       GNH= DB10( GCON* EPHM2)
  7408.       GTOT= DB10( GCON*( ETHM2+ EPHM2))
  7409.       IF( INOR.LT.1) GOTO 23
  7410.       I= I+1
  7411.       IF( I.GT. NORMAX) GOTO 23
  7412.       GOTO (17,18,19,20,21), INOR
  7413.    17 TSTOR1= GNMJ
  7414.       GOTO 22
  7415.    18 TSTOR1= GNMN
  7416.       GOTO 22
  7417.    19 TSTOR1= GNV
  7418.       GOTO 22
  7419.    20 TSTOR1= GNH
  7420.       GOTO 22
  7421.    21 TSTOR1= GTOT
  7422.    22 GAIN( I)= TSTOR1
  7423.       IF( TSTOR1.GT. GMAX) GMAX= TSTOR1
  7424.    23 IF( IAVP.EQ.0) GOTO 24
  7425.       TSTOR1= GCOP*( ETHM2+ EPHM2)
  7426.       TMP3= THA- TMP2
  7427.       TMP4= THA+ TMP2
  7428.       IF( KTH.EQ.1) TMP3= THA
  7429.       IF( KTH.EQ. NTH) TMP4= THA
  7430.       DA= ABS( TMP1*( COS( TMP3)- COS( TMP4)))
  7431.       IF( KPH.EQ.1.OR. KPH.EQ. NPH) DA=.5* DA
  7432.       PINT= PINT+ TSTOR1* DA
  7433.       IF( IAVP.EQ.2) GOTO 29
  7434.    24 IF( IAX.EQ.1) GOTO 25
  7435.       TMP5= GNMJ
  7436.       TMP6= GNMN
  7437.       GOTO 26
  7438.    25 TMP5= GNV
  7439.       TMP6= GNH
  7440.    26 ETHM= ETHM* WLAM
  7441.       EPHM= EPHM* WLAM
  7442.       IF( RFLD.LT.1.D-20) GOTO 27
  7443.       ETHM= ETHM* EXRM
  7444.       ETHA= ETHA+ EXRA
  7445.       EPHM= EPHM* EXRM
  7446.       EPHA= EPHA+ EXRA
  7447. C      GO TO 29                                                         
  7448. C***
  7449. C28    WRITE(6,43)  RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA         
  7450.    27 WRITE( 6,42)  THET, PHI, TMP5, TMP6, GTOT, AXRAT, TILTA, ISENS, 
  7451.      ÐM, ETHA, EPHM, EPHA
  7452.       IF( IPLP1.NE.3) GOTO 299
  7453.       IF( IPLP3.EQ.0) GOTO 290
  7454.       IF( IPLP2.EQ.1.AND. IPLP3.EQ.1) WRITE( 8,*)  THET, ETHM, ETHA
  7455.       IF( IPLP2.EQ.1.AND. IPLP3.EQ.2) WRITE( 8,*)  THET, EPHM, EPHA
  7456.       IF( IPLP2.EQ.2.AND. IPLP3.EQ.1) WRITE( 8,*)  PHI, ETHM, ETHA
  7457.       IF( IPLP2.EQ.2.AND. IPLP3.EQ.2) WRITE( 8,*)  PHI, EPHM, EPHA
  7458.       IF( IPLP4.EQ.0) GOTO 299
  7459.   290 IF( IPLP2.EQ.1.AND. IPLP4.EQ.1) WRITE( 8,*)  THET, TMP5
  7460.       IF( IPLP2.EQ.1.AND. IPLP4.EQ.2) WRITE( 8,*)  THET, TMP6
  7461.       IF( IPLP2.EQ.1.AND. IPLP4.EQ.3) WRITE( 8,*)  THET, GTOT
  7462.       IF( IPLP2.EQ.2.AND. IPLP4.EQ.1) WRITE( 8,*)  PHI, TMP5
  7463.       IF( IPLP2.EQ.2.AND. IPLP4.EQ.2) WRITE( 8,*)  PHI, TMP6
  7464.       IF( IPLP2.EQ.2.AND. IPLP4.EQ.3) WRITE( 8,*)  PHI, GTOT
  7465.       GOTO 299
  7466.    28 WRITE( 6,43)  RFLD, PHI, THET, ETHM, ETHA, EPHM, EPHA, ERDM, ERDA
  7467.      &
  7468. C***
  7469.   299 CONTINUE
  7470.    29 CONTINUE
  7471.       IF( IAVP.EQ.0) GOTO 30
  7472.       TMP3= THETS* TA
  7473.       TMP4= TMP3+ DTH* TA* DFLOAT( NTH-1)
  7474.       TMP3= ABS( DPH* TA* DFLOAT( NPH-1)*( COS( TMP3)- COS( TMP4)))
  7475.       PINT= PINT/ TMP3
  7476.       TMP3= TMP3/ PI
  7477.       WRITE( 6,44)  PINT, TMP3
  7478.    30 IF( INOR.EQ.0) GOTO 34
  7479.       IF( ABS( GNOR).GT.1.D-20) GMAX= GNOR
  7480.       ITMP1=( INOR-1)*2+1
  7481.       ITMP2= ITMP1+1
  7482.       WRITE( 6,45)  IGNTP( ITMP1), IGNTP( ITMP2), GMAX
  7483.       ITMP2= NPH* NTH
  7484.       IF( ITMP2.GT. NORMAX) ITMP2= NORMAX
  7485.       ITMP1=( ITMP2+2)/3
  7486.       ITMP2= ITMP1*3- ITMP2
  7487.       ITMP3= ITMP1
  7488.       ITMP4=2* ITMP1
  7489.       IF( ITMP2.EQ.2) ITMP4= ITMP4-1
  7490.       DO 31  I=1, ITMP1
  7491.       ITMP3= ITMP3+1
  7492.       ITMP4= ITMP4+1
  7493.       J=( I-1)/ NTH
  7494.       TMP1= THETS+ DFLOAT( I- J* NTH-1)* DTH
  7495.       TMP2= PHIS+ DFLOAT( J)* DPH
  7496.       J=( ITMP3-1)/ NTH
  7497.       TMP3= THETS+ DFLOAT( ITMP3- J* NTH-1)* DTH
  7498.       TMP4= PHIS+ DFLOAT( J)* DPH
  7499.       J=( ITMP4-1)/ NTH
  7500.       TMP5= THETS+ DFLOAT( ITMP4- J* NTH-1)* DTH
  7501.       TMP6= PHIS+ DFLOAT( J)* DPH
  7502.       TSTOR1= GAIN( I)- GMAX
  7503.       IF( I.EQ. ITMP1.AND. ITMP2.NE.0) GOTO 32
  7504.       TSTOR2= GAIN( ITMP3)- GMAX
  7505.       PINT= GAIN( ITMP4)- GMAX
  7506.    31 WRITE( 6,46)  TMP1, TMP2, TSTOR1, TMP3, TMP4, TSTOR2, TMP5, TMP6,
  7507.      & PINT
  7508.       GOTO 34
  7509.    32 IF( ITMP2.EQ.2) GOTO 33
  7510.       TSTOR2= GAIN( ITMP3)- GMAX
  7511.       WRITE( 6,46)  TMP1, TMP2, TSTOR1, TMP3, TMP4, TSTOR2
  7512.       GOTO 34
  7513.    33 WRITE( 6,46)  TMP1, TMP2, TSTOR1
  7514. C                                                                       
  7515.    34 RETURN
  7516.    35 FORMAT(///,31X,'- - - FAR FIELD GROUND PARAMETERS - - -',//)
  7517.    36 FORMAT(40X,'RADIAL WIRE GROUND SCREEN',/,40X,I5,' WIRES',/,40X,
  7518.      &'WIRE LENGTH=',F8.2,' METERS',/,40X,'WIRE RADIUS=',1P,E10.3,
  7519.      &' METERS')
  7520.    37 FORMAT(40X,A6,' CLIFF',/,40X,'EDGE DISTANCE=',F9.2,' METERS',/,40
  7521.      &X,'HEIGHT=',F8.2,' METERS',/,40X,'SECOND MEDIUM -',/,40X,'RELA',
  7522.      &'TIVE DIELECTRIC CONST.=',F7.3,/,40X,'CONDUCTIVITY=',1P,E10.3,
  7523.      &' MHOS')
  7524.    38 FORMAT(///,48X,'- - - RADIATION PATTERNS - - -')
  7525.    39 FORMAT(54X,'RANGE=',1P,E13.6,' METERS',/,54X,'EXP(-JKR)/R=',E12.5
  7526.      &,' AT PHASE',0P,F7.2,' DEGREES',/)
  7527.    40 FORMAT(/,2X,'- - ANGLES - -',7X,2A6,'GAINS -',7X,'- - - POLARI',
  7528.      &'ZATION - - -',4X,'- - - E(THETA) - - -',4X,'- - - E(PHI) - -',
  7529.      &' -',/,2X,'THETA',5X,'PHI',7X,A6,2X,A6,3X,'TOTAL',6X,'AXIAL',5X,
  7530.      &'TILT',3X,'SENSE',2(5X,'MAGNITUDE',4X,'PHASE'),/,2(1X,'DEGREES',1
  7531.      &X),3(6X,'DB'),8X,'RATIO',5X,'DEG.',8X,2(6X,'VOLTS/M',4X,'DEGRE',
  7532.      &'ES'))
  7533.    41 FORMAT(///,28X,' - - - RADIATED FIELDS NEAR GROUND - - -',//,8X,
  7534.      &'- - - LOCATION - - -',10X,'- - E(THETA) - -',8X,'- - E(PHI) -'
  7535.      &' -',8X,'- - E(RADIAL) - -',/,7X,'RHO',6X,'PHI',9X,'Z',12X,'MAG',
  7536.      &6X,'PHASE',9X,'MAG',6X,'PHASE',9X,'MAG',6X,'PHASE',/,5X,'METERS',
  7537.      &3X,'DEGREES',4X,'METERS',8X,'VOLTS/M',3X,'DEGREES',6X,'VOLTS/M',3
  7538.      &X,'DEGREES',6X,'VOLTS/M',3X,'DEGREES',/)
  7539.    42 FORMAT(1X,F7.2,F9.2,3X,3F8.2,F11.5,F9.2,2X,A6,2(1P,E15.5,0P,F9.2)
  7540.      &)
  7541.    43 FORMAT(3X,F9.2,2X,F7.2,2X,F9.2,1X,3(3X,1P,E11.4,2X,0P,F7.2))
  7542.    44 FORMAT(//,3X,'AVERAGE POWER GAIN=',1P,E12.5,7X,'SOLID ANGLE U',
  7543.      &'SED IN AVERAGING=(',0P,F7.4,')*PI STERADIANS.',//)
  7544.    45 FORMAT(//,37X,'- - - - NORMALIZED GAIN - - - -',//,37X,2A6,'GAI',
  7545.      &'N',/,38X,'NORMALIZATION FACTOR =',F9.2,' DB',//,3(4X,
  7546.      &'- - ANGLES'' - -',6X,'GAIN',7X),/,3(4X,'THETA',5X,'PHI',8X,'DB',
  7547.      &8X),/,3(3X,'DEGREES',2X,'DEGREES',16X))
  7548.    46 FORMAT(3(1X,2F9.2,1X,F9.2,6X))
  7549.       END
  7550. C ***
  7551. C     DOUBLE PRECISION 6/4/85
  7552. C
  7553.       SUBROUTINE READGM( GM, I1, I2, X1, Y1, Z1, X2, Y2, Z2, RAD)
  7554. C ***
  7555.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  7556.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  7557.       INTEGER*4 NTOT
  7558.       INTEGER*4 NINT
  7559.       INTEGER*4 NFLT
  7560.       PARAMETER (NTOT=9, NINT=2, NFLT=7)
  7561.       INTEGER  IARR( NINT), BP( NTOT), EP( NTOT)
  7562.       DIMENSION  RARR( NFLT)
  7563.       CHARACTER   LINE*133, GM*2, BUFFER*132, BUFFER1*132
  7564.       READ( 5,10)  LINE
  7565.    10 FORMAT(A)
  7566.       NLIN= LEN(LINE)
  7567.       CALL STR0PC( LINE(1: NLIN), LINE(1: NLIN))
  7568.       IF( NLIN.LT.2) GOTO 110
  7569.       IF( NLIN.LE.132) GOTO 20
  7570.       NLIN=132
  7571.       LINE(133:133)=' '
  7572.    20 GM= LINE(1:2)
  7573.       NLIN= NLIN+1
  7574.       DO 30  I=1, NINT
  7575.    30 IARR( I)=0
  7576.       DO 40  I=1, NFLT
  7577.    40 RARR( I)=0.0
  7578.       IC=2
  7579.       IFOUND=0
  7580.       DO 70  I=1, NTOT
  7581.    50 IC= IC+1
  7582.       IF( IC.GE. NLIN) GOTO 80
  7583.       IF( LINE( IC: IC).EQ.' '.OR. LINE( IC: IC).EQ.',') GOTO 50
  7584. C BEGINNING OF I-TH NUMERICAL FIELD
  7585.       BP( I)= IC
  7586.    60 IC= IC+1
  7587.       IF( IC.GT. NLIN) GOTO 80
  7588.       IF( LINE( IC: IC).NE.' '.AND. LINE( IC: IC).NE.',') GOTO 60
  7589. C END OF I-TH NUMERICAL FIELD
  7590.       EP( I)= IC-1
  7591.       IFOUND= I
  7592.    70 CONTINUE
  7593.    80 CONTINUE
  7594.       DO 90  I=1, MIN( IFOUND, NINT)
  7595.       NLEN= EP( I)- BP( I)+1
  7596.       BUFFER= LINE( BP( I): EP( I))
  7597.       IND= INDEX( BUFFER(1: NLEN),'.')
  7598.       IF( IND.GT.0.AND. IND.LT. NLEN) GOTO 110
  7599. C USER PUT DECIMAL POINT FOR INTEGER
  7600.       IF( IND.EQ. NLEN) NLEN= NLEN-1
  7601. C     READ( BUFFER(1: NLEN),111,ERR=110)  IARR( I)
  7602. C11   format(i3)
  7603.       CALL ATOI(BUFFER,IARR(I))
  7604.    90 CONTINUE
  7605.       DO 100  I= NINT+1, IFOUND
  7606.       NLEN= EP( I)- BP( I)+1
  7607.       BUFFER= LINE( BP( I): EP( I))
  7608.       IND= INDEX( BUFFER(1: NLEN),'.')
  7609. C USER FORGOT DECIMAL POINT FOR REAL
  7610.       IF( IND.EQ.0) THEN
  7611.       IF( NLEN.GE.15) GOTO 110
  7612.       INDE= INDEX( BUFFER(1: NLEN),'E')
  7613.       NLEN= NLEN+1
  7614.       IF( INDE.EQ.0) THEN
  7615.       BUFFER( NLEN: NLEN)='.'
  7616.       ELSE
  7617.       BUFFER1= BUFFER(1: INDD-1)//'.'// BUFFER( INDE: NLEN-1)
  7618.       BUFFER= BUFFER1
  7619.       ENDIF
  7620.       ENDIF
  7621. C     READ( BUFFER(1: NLEN),112,ERR=110)  RARR( I- NINT)
  7622. C 112 format (F15.7)
  7623.       CALL ATOF(BUFFER,RARR( I- NINT))
  7624.   100 CONTINUE
  7625.       I1= IARR(1)
  7626.       I2= IARR(2)
  7627.       X1= RARR(1)
  7628.       Y1= RARR(2)
  7629.       Z1= RARR(3)
  7630.       X2= RARR(4)
  7631.       Y2= RARR(5)
  7632.       Z2= RARR(6)
  7633.       RAD= RARR(7)
  7634.       RETURN
  7635.   110 WRITE( 6,*) ' GEOMETRY DATA CARD ERROR'
  7636.       WRITE( 6,*)  LINE(1: MAX(1, NLIN-1))
  7637.       STOP
  7638.       END
  7639. C ***
  7640. C     DOUBLE PRECISION 6/4/85
  7641. C
  7642.       SUBROUTINE READMN( GM, I1, I2, I3, I4, F1, F2, F3, F4, F5, F6)
  7643. C ***
  7644.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  7645.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  7646.       INTEGER*4 NTOT
  7647.       INTEGER*4 NINT
  7648.       INTEGER*4 NFLT
  7649.       PARAMETER (NTOT=10, NINT=4, NFLT=6)
  7650.       INTEGER  IARR( NINT), BP( NTOT), EP( NTOT)
  7651.       DIMENSION  RARR( NFLT)
  7652.       CHARACTER   LINE*133, GM*2, BUFFER*132, BUFFER1*132
  7653.       READ( 5,10)  LINE
  7654.    10 FORMAT(A)
  7655.       NLIN= LEN(LINE)
  7656.       CALL STR0PC( LINE(1: NLIN), LINE(1: NLIN))
  7657.       IF( NLIN.LT.2) GOTO 110
  7658.       IF( NLIN.LE.132) GOTO 20
  7659.       NLIN=132
  7660.       LINE(133:133)=' '
  7661.    20 GM= LINE(1:2)
  7662.       NLIN= NLIN+1
  7663.       DO 30  I=1, NINT
  7664.    30 IARR( I)=0
  7665.       DO 40  I=1, NFLT
  7666.    40 RARR( I)=0.0
  7667.       IC=2
  7668.       IFOUND=0
  7669.       DO 70  I=1, NTOT
  7670.    50 IC= IC+1
  7671.       IF( IC.GE. NLIN) GOTO 80
  7672.       IF( LINE( IC: IC).EQ.' '.OR. LINE( IC: IC).EQ.',') GOTO 50
  7673. C BEGINNING OF I-TH NUMERICAL FIELD
  7674.       BP( I)= IC
  7675.    60 IC= IC+1
  7676.       IF( IC.GT. NLIN) GOTO 80
  7677.       IF( LINE( IC: IC).NE.' '.AND. LINE( IC: IC).NE.',') GOTO 60
  7678. C END OF I-TH NUMERICAL FIELD
  7679.       EP( I)= IC-1
  7680.       IFOUND= I
  7681.    70 CONTINUE
  7682.    80 CONTINUE
  7683.       DO 90  I=1, MIN( IFOUND, NINT)
  7684.       NLEN= EP( I)- BP( I)+1
  7685.       BUFFER= LINE( BP( I): EP( I))
  7686.       IND= INDEX( BUFFER(1: NLEN),'.')
  7687.       IF( IND.GT.0.AND. IND.LT. NLEN) GOTO 110
  7688. C USER PUT DECIMAL POINT FOR INTEGER
  7689.       IF( IND.EQ. NLEN) NLEN= NLEN-1
  7690. C     READ( BUFFER(1: NLEN),111,ERR=110)  IARR( I)
  7691. C 111 format(I5)
  7692.       CALL ATOI(BUFFER,IARR(I))
  7693.    90 CONTINUE
  7694.       DO 100  I= NINT+1, IFOUND
  7695.       NLEN= EP( I)- BP( I)+1
  7696.       BUFFER= LINE( BP( I): EP( I))
  7697.       IND= INDEX( BUFFER(1: NLEN),'.')
  7698. C USER FORGOT DECIMAL POINT FOR REAL
  7699.       IF( IND.EQ.0) THEN
  7700.       IF( NLEN.GE.15) GOTO 110
  7701.       INDE= INDEX( BUFFER(1: NLEN),'E')
  7702.       NLEN= NLEN+1
  7703.       IF( INDE.EQ.0) THEN
  7704.       BUFFER( NLEN: NLEN)='.'
  7705.       ELSE
  7706.       BUFFER1= BUFFER(1: INDD-1)//'.'// BUFFER( INDE: NLEN-1)
  7707.       BUFFER= BUFFER1
  7708.       ENDIF
  7709.       ENDIF
  7710. C     READ( BUFFER(1: NLEN),112,ERR=110)  RARR( I- NINT)
  7711. C 112 format(F15.7)
  7712.       CALL ATOF(BUFFER,RARR( I- NINT))
  7713.   100 CONTINUE
  7714.       I1= IARR(1)
  7715.       I2= IARR(2)
  7716.       I3= IARR(3)
  7717.       I4= IARR(4)
  7718.       F1= RARR(1)
  7719.       F2= RARR(2)
  7720.       F3= RARR(3)
  7721.       F4= RARR(4)
  7722.       F5= RARR(5)
  7723.       F6= RARR(6)
  7724.       RETURN
  7725.   110 WRITE( 6,*) '          FAULTY DATA CARD AFTER GEOMETRY SECTION'
  7726.       WRITE( 6,*)  LINE(1: MAX(1, NLIN-1))
  7727.       STOP
  7728.       END
  7729. C ***
  7730. C     DOUBLE PRECISION 6/4/85
  7731. C
  7732.       SUBROUTINE REBLK( B, BX, NB, NBX, N2C)
  7733. C ***
  7734. C     REBLOCK ARRAY B IN N.G.F. SOLUTION FROM BLOCKS OF ROWS ON TAPE14  
  7735. C     TO BLOCKS OF COLUMNS ON TAPE16                                    
  7736.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  7737.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  7738.       COMPLEX  B, BX
  7739.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  7740.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  7741.       DIMENSION  B( NB,1), BX( NBX,1)
  7742.       REWIND 16
  7743.       NIB=0
  7744.       NPB= NPBL
  7745.       DO 3  IB=1, NBBL
  7746.       IF( IB.EQ. NBBL) NPB= NLBL
  7747.       REWIND 14
  7748.       NIX=0
  7749.       NPX= NPBX
  7750.       DO 2  IBX=1, NBBX
  7751.       IF( IBX.EQ. NBBX) NPX= NLBX
  7752.       READ( 14) (( BX( I, J), I=1, NPX), J=1, N2C)
  7753.       DO 1  I=1, NPX
  7754.       IX= I+ NIX
  7755.       DO 1  J=1, NPB
  7756.     1 B( IX, J)= BX( I, J+ NIB)
  7757.     2 NIX= NIX+ NPBX
  7758.       WRITE( 16) (( B( I, J), I=1, NB), J=1, NPB)
  7759.     3 NIB= NIB+ NPBL
  7760.       REWIND 14
  7761.       REWIND 16
  7762.       RETURN
  7763.       END
  7764. C ***
  7765. C     DOUBLE PRECISION 6/4/85
  7766. C
  7767.       SUBROUTINE REFLC( IX, IY, IZ, ITX, NOP)
  7768. C ***
  7769. C                                                                       
  7770. C     REFLC REFLECTS PARTIAL STRUCTURE ALONG X,Y, OR Z AXES OR ROTATES  
  7771. C     STRUCTURE TO COMPLETE A SYMMETRIC STRUCTURE.                      
  7772. C                                                                       
  7773.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  7774.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  7775.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  7776.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  7777.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  7778.       COMMON  /ANGL/ SALP( NM)
  7779.       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), X2(1),
  7780.      & Y2(1), Z2(1)
  7781.       EQUIVALENCE(T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),(
  7782.      &T2Z,ITAG),(X2,SI),(Y2,ALP),(Z2,BET)
  7783.       NP= N
  7784.       MP= M
  7785.       IPSYM=0
  7786.       ITI= ITX
  7787.       IF( IX.LT.0) GOTO 19
  7788.       IF( NOP.EQ.0) RETURN
  7789.       IPSYM=1
  7790. C                                                                       
  7791. C     REFLECT ALONG Z AXIS                                              
  7792. C                                                                       
  7793.       IF( IZ.EQ.0) GOTO 6
  7794.       IPSYM=2
  7795.       IF( N.LT. N2) GOTO 3
  7796.       DO 2  I= N2, N
  7797.       NX= I+ N- N1
  7798.       E1= Z( I)
  7799.       E2= Z2( I)
  7800.       IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 1
  7801.       WRITE( 6,24)  I
  7802.       STOP
  7803.     1 X( NX)= X( I)
  7804.       Y( NX)= Y( I)
  7805.       Z( NX)=- E1
  7806.       X2( NX)= X2( I)
  7807.       Y2( NX)= Y2( I)
  7808.       Z2( NX)=- E2
  7809.       ITAGI= ITAG( I)
  7810.       IF( ITAGI.EQ.0) ITAG( NX)=0
  7811.       IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI
  7812.     2 BI( NX)= BI( I)
  7813.       N= N*2- N1
  7814.       ITI= ITI*2
  7815.     3 IF( M.LT. M2) GOTO 6
  7816.       NXX= LD+1- M1
  7817.       DO 5  I= M2, M
  7818.       NXX= NXX-1
  7819.       NX= NXX- M+ M1
  7820.       IF( ABS( Z( NXX)).GT.1.D-10) GOTO 4
  7821.       WRITE( 6,25)  I
  7822.       STOP
  7823.     4 X( NX)= X( NXX)
  7824.       Y( NX)= Y( NXX)
  7825.       Z( NX)=- Z( NXX)
  7826.       T1X( NX)= T1X( NXX)
  7827.       T1Y( NX)= T1Y( NXX)
  7828.       T1Z( NX)=- T1Z( NXX)
  7829.       T2X( NX)= T2X( NXX)
  7830.       T2Y( NX)= T2Y( NXX)
  7831.       T2Z( NX)=- T2Z( NXX)
  7832.       SALP( NX)=- SALP( NXX)
  7833.     5 BI( NX)= BI( NXX)
  7834.       M= M*2- M1
  7835. C                                                                       
  7836. C     REFLECT ALONG Y AXIS                                              
  7837. C                                                                       
  7838.     6 IF( IY.EQ.0) GOTO 12
  7839.       IF( N.LT. N2) GOTO 9
  7840.       DO 8  I= N2, N
  7841.       NX= I+ N- N1
  7842.       E1= Y( I)
  7843.       E2= Y2( I)
  7844.       IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 7
  7845.       WRITE( 6,24)  I
  7846.       STOP
  7847.     7 X( NX)= X( I)
  7848.       Y( NX)=- E1
  7849.       Z( NX)= Z( I)
  7850.       X2( NX)= X2( I)
  7851.       Y2( NX)=- E2
  7852.       Z2( NX)= Z2( I)
  7853.       ITAGI= ITAG( I)
  7854.       IF( ITAGI.EQ.0) ITAG( NX)=0
  7855.       IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI
  7856.     8 BI( NX)= BI( I)
  7857.       N= N*2- N1
  7858.       ITI= ITI*2
  7859.     9 IF( M.LT. M2) GOTO 12
  7860.       NXX= LD+1- M1
  7861.       DO 11  I= M2, M
  7862.       NXX= NXX-1
  7863.       NX= NXX- M+ M1
  7864.       IF( ABS( Y( NXX)).GT.1.D-10) GOTO 10
  7865.       WRITE( 6,25)  I
  7866.       STOP
  7867.    10 X( NX)= X( NXX)
  7868.       Y( NX)=- Y( NXX)
  7869.       Z( NX)= Z( NXX)
  7870.       T1X( NX)= T1X( NXX)
  7871.       T1Y( NX)=- T1Y( NXX)
  7872.       T1Z( NX)= T1Z( NXX)
  7873.       T2X( NX)= T2X( NXX)
  7874.       T2Y( NX)=- T2Y( NXX)
  7875.       T2Z( NX)= T2Z( NXX)
  7876.       SALP( NX)=- SALP( NXX)
  7877.    11 BI( NX)= BI( NXX)
  7878.       M= M*2- M1
  7879. C                                                                       
  7880. C     REFLECT ALONG X AXIS                                              
  7881. C                                                                       
  7882.    12 IF( IX.EQ.0) GOTO 18
  7883.       IF( N.LT. N2) GOTO 15
  7884.       DO 14  I= N2, N
  7885.       NX= I+ N- N1
  7886.       E1= X( I)
  7887.       E2= X2( I)
  7888.       IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 13
  7889.       WRITE( 6,24)  I
  7890.       STOP
  7891.    13 X( NX)=- E1
  7892.       Y( NX)= Y( I)
  7893.       Z( NX)= Z( I)
  7894.       X2( NX)=- E2
  7895.       Y2( NX)= Y2( I)
  7896.       Z2( NX)= Z2( I)
  7897.       ITAGI= ITAG( I)
  7898.       IF( ITAGI.EQ.0) ITAG( NX)=0
  7899.       IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI
  7900.    14 BI( NX)= BI( I)
  7901.       N= N*2- N1
  7902.    15 IF( M.LT. M2) GOTO 18
  7903.       NXX= LD+1- M1
  7904.       DO 17  I= M2, M
  7905.       NXX= NXX-1
  7906.       NX= NXX- M+ M1
  7907.       IF( ABS( X( NXX)).GT.1.D-10) GOTO 16
  7908.       WRITE( 6,25)  I
  7909.       STOP
  7910.    16 X( NX)=- X( NXX)
  7911.       Y( NX)= Y( NXX)
  7912.       Z( NX)= Z( NXX)
  7913.       T1X( NX)=- T1X( NXX)
  7914.       T1Y( NX)= T1Y( NXX)
  7915.       T1Z( NX)= T1Z( NXX)
  7916.       T2X( NX)=- T2X( NXX)
  7917.       T2Y( NX)= T2Y( NXX)
  7918.       T2Z( NX)= T2Z( NXX)
  7919.       SALP( NX)=- SALP( NXX)
  7920.    17 BI( NX)= BI( NXX)
  7921.       M= M*2- M1
  7922. C                                                                       
  7923. C     REPRODUCE STRUCTURE WITH ROTATION TO FORM CYLINDRICAL STRUCTURE   
  7924. C                                                                       
  7925.    18 RETURN
  7926.    19 FNOP= NOP
  7927.       IPSYM=-1
  7928.       SAM=6.283185308D+0/ FNOP
  7929.       CS= COS( SAM)
  7930.       SS= SIN( SAM)
  7931.       IF( N.LT. N2) GOTO 21
  7932.       N= N1+( N- N1)* NOP
  7933.       NX= NP+1
  7934.       DO 20  I= NX, N
  7935.       K= I- NP+ N1
  7936.       XK= X( K)
  7937.       YK= Y( K)
  7938.       X( I)= XK* CS- YK* SS
  7939.       Y( I)= XK* SS+ YK* CS
  7940.       Z( I)= Z( K)
  7941.       XK= X2( K)
  7942.       YK= Y2( K)
  7943.       X2( I)= XK* CS- YK* SS
  7944.       Y2( I)= XK* SS+ YK* CS
  7945.       Z2( I)= Z2( K)
  7946.       ITAGI= ITAG( K)
  7947.       IF( ITAGI.EQ.0) ITAG( I)=0
  7948.       IF( ITAGI.NE.0) ITAG( I)= ITAGI+ ITI
  7949.    20 BI( I)= BI( K)
  7950.    21 IF( M.LT. M2) GOTO 23
  7951.       M= M1+( M- M1)* NOP
  7952.       NX= MP+1
  7953.       K= LD+1- M1
  7954.       DO 22  I= NX, M
  7955.       K= K-1
  7956.       J= K- MP+ M1
  7957.       XK= X( K)
  7958.       YK= Y( K)
  7959.       X( J)= XK* CS- YK* SS
  7960.       Y( J)= XK* SS+ YK* CS
  7961.       Z( J)= Z( K)
  7962.       XK= T1X( K)
  7963.       YK= T1Y( K)
  7964.       T1X( J)= XK* CS- YK* SS
  7965.       T1Y( J)= XK* SS+ YK* CS
  7966.       T1Z( J)= T1Z( K)
  7967.       XK= T2X( K)
  7968.       YK= T2Y( K)
  7969.       T2X( J)= XK* CS- YK* SS
  7970.       T2Y( J)= XK* SS+ YK* CS
  7971.       T2Z( J)= T2Z( K)
  7972.       SALP( J)= SALP( K)
  7973.    22 BI( J)= BI( K)
  7974. C                                                                       
  7975.    23 RETURN
  7976.    24 FORMAT(' GEOMETRY DATA ERROR--SEGMENT,I5,26H LIES IN PLANE OF S',
  7977.      &'YMMETRY')
  7978.    25 FORMAT(' GEOMETRY DATA ERROR--PATCH,I4,26H LIES IN PLANE OF SYM',
  7979.      &'METRY')
  7980.       END
  7981. C ***
  7982. C     DOUBLE PRECISION 6/4/85
  7983. C
  7984.       SUBROUTINE ROM2( A, B, SUM, DMIN)
  7985. C ***
  7986. C                                                                       
  7987. C     FOR THE SOMMERFELD GROUND OPTION, ROM2 INTEGRATES OVER THE SOURCE 
  7988. C     SEGMENT TO OBTAIN THE TOTAL FIELD DUE TO GROUND.  THE METHOD OF   
  7989. C     VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION IS USED.  THERE ARE 9 
  7990. C     FIELD COMPONENTS - THE X, Y, AND Z COMPONENTS DUE TO CONSTANT,    
  7991. C     SINE, AND COSINE CURRENT DISTRIBUTIONS.                           
  7992. C                                                                       
  7993.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  7994.       COMPLEX  SUM, G1, G2, G3, G4, G5, T00, T01, T10, T02, T11, T20
  7995.      &
  7996.       DIMENSION  SUM(9), G1(9), G2(9), G3(9), G4(9), G5(9), T01(9), T10
  7997.      &(9), T20(9)
  7998.       DATA   NM, NTS, NX, N/65536,4,1,9/, RX/1.D-4/
  7999.       Z= A
  8000.       ZE= B
  8001.       S= B- A
  8002.       IF( S.GE.0.) GOTO 1
  8003.       WRITE( 6,18) 
  8004.       STOP
  8005.     1 EP= S/(1.E4* NM)
  8006.       ZEND= ZE- EP
  8007.       DO 2  I=1, N
  8008.     2 SUM( I)=(0.,0.)
  8009.       NS= NX
  8010.       NT=0
  8011.       CALL SFLDS( Z, G1)
  8012.     3 DZ= S/ NS
  8013.       IF( Z+ DZ.LE. ZE) GOTO 4
  8014.       DZ= ZE- Z
  8015.       IF( DZ.LE. EP) GOTO 17
  8016.     4 DZOT= DZ*.5
  8017.       CALL SFLDS( Z+ DZOT, G3)
  8018.       CALL SFLDS( Z+ DZ, G5)
  8019.     5 TMAG1=0.
  8020. C                                                                       
  8021. C     EVALUATE 3 POINT ROMBERG RESULT AND TEST CONVERGENCE.             
  8022. C                                                                       
  8023.       TMAG2=0.
  8024.       DO 6  I=1, N
  8025.       T00=( G1( I)+ G5( I))* DZOT
  8026.       T01( I)=( T00+ DZ* G3( I))*.5
  8027.       T10( I)=(4.* T01( I)- T00)/3.
  8028.       IF( I.GT.3) GOTO 6
  8029.       TR= REAL( T01( I))
  8030.       TI= AIMAG( T01( I))
  8031.       TMAG1= TMAG1+ TR* TR+ TI* TI
  8032.       TR= REAL( T10( I))
  8033.       TI= AIMAG( T10( I))
  8034.       TMAG2= TMAG2+ TR* TR+ TI* TI
  8035.     6 CONTINUE
  8036.       TMAG1= SQRT( TMAG1)
  8037.       TMAG2= SQRT( TMAG2)
  8038.       CALL TEST( TMAG1, TMAG2, TR,0.,0., TI, DMIN)
  8039.       IF( TR.GT. RX) GOTO 8
  8040.       DO 7  I=1, N
  8041.     7 SUM( I)= SUM( I)+ T10( I)
  8042.       NT= NT+2
  8043.       GOTO 12
  8044.     8 CALL SFLDS( Z+ DZ*.25, G2)
  8045.       CALL SFLDS( Z+ DZ*.75, G4)
  8046.       TMAG1=0.
  8047. C                                                                       
  8048. C     EVALUATE 5 POINT ROMBERG RESULT AND TEST CONVERGENCE.             
  8049. C                                                                       
  8050.       TMAG2=0.
  8051.       DO 9  I=1, N
  8052.       T02=( T01( I)+ DZOT*( G2( I)+ G4( I)))*.5
  8053.       T11=(4.* T02- T01( I))/3.
  8054.       T20( I)=(16.* T11- T10( I))/15.
  8055.       IF( I.GT.3) GOTO 9
  8056.       TR= REAL( T11)
  8057.       TI= AIMAG( T11)
  8058.       TMAG1= TMAG1+ TR* TR+ TI* TI
  8059.       TR= REAL( T20( I))
  8060.       TI= AIMAG( T20( I))
  8061.       TMAG2= TMAG2+ TR* TR+ TI* TI
  8062.     9 CONTINUE
  8063.       TMAG1= SQRT( TMAG1)
  8064.       TMAG2= SQRT( TMAG2)
  8065.       CALL TEST( TMAG1, TMAG2, TR,0.,0., TI, DMIN)
  8066.       IF( TR.GT. RX) GOTO 14
  8067.    10 DO 11  I=1, N
  8068.    11 SUM( I)= SUM( I)+ T20( I)
  8069.       NT= NT+1
  8070.    12 Z= Z+ DZ
  8071.       IF( Z.GT. ZEND) GOTO 17
  8072.       DO 13  I=1, N
  8073.    13 G1( I)= G5( I)
  8074.       IF( NT.LT. NTS.OR. NS.LE. NX) GOTO 3
  8075.       NS= NS/2
  8076.       NT=1
  8077.       GOTO 3
  8078.    14 NT=0
  8079.       IF( NS.LT. NM) GOTO 15
  8080.       WRITE( 6,19)  Z
  8081.       GOTO 10
  8082.    15 NS= NS*2
  8083.       DZ= S/ NS
  8084.       DZOT= DZ*.5
  8085.       DO 16  I=1, N
  8086.       G5( I)= G3( I)
  8087.    16 G3( I)= G2( I)
  8088.       GOTO 5
  8089.    17 CONTINUE
  8090. C                                                                       
  8091.       RETURN
  8092.    18 FORMAT(' ERROR - B LESS THAN A IN ROM2')
  8093.    19 FORMAT(' ROM2 -- STEP SIZE LIMITED AT Z =',1P,E12.5)
  8094.       END
  8095. C ***
  8096. C     DOUBLE PRECISION 6/4/85
  8097. C
  8098.       SUBROUTINE SBF( I, IS, AA, BB, CC)
  8099. C ***
  8100. C     COMPUTE COMPONENT OF BASIS FUNCTION I ON SEGMENT IS.              
  8101.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  8102.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  8103.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  8104.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  8105.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  8106.       DATA   PI/3.141592654D+0/, JMAX/30/
  8107.       AA=0.
  8108.       BB=0.
  8109.       CC=0.
  8110.       JUNE=0
  8111.       JSNO=0
  8112.       PP=0.
  8113.       JCOX= ICON1( I)
  8114.       IF( JCOX.GT.10000) JCOX= I
  8115.       JEND=-1
  8116.       IEND=-1
  8117.       SIG=-1.
  8118.       IF( JCOX) 1,11,2
  8119.     1 JCOX=- JCOX
  8120.       GOTO 3
  8121.     2 SIG=- SIG
  8122.       JEND=- JEND
  8123.     3 JSNO= JSNO+1
  8124.       IF( JSNO.GE. JMAX) GOTO 24
  8125.       D= PI* SI( JCOX)
  8126.       SDH= SIN( D)
  8127.       CDH= COS( D)
  8128.       SD=2.* SDH* CDH
  8129.       IF( D.GT.0.015) GOTO 4
  8130.       OMC=4.* D* D
  8131.       OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC
  8132.       GOTO 5
  8133.     4 OMC=1.- CDH* CDH+ SDH* SDH
  8134.     5 AJ=1./( LOG(1./( PI* BI( JCOX)))-.577215664D+0)
  8135.       PP= PP- OMC/ SD* AJ
  8136.       IF( JCOX.NE. IS) GOTO 6
  8137.       AA= AJ/ SD* SIG
  8138.       BB= AJ/(2.* CDH)
  8139.       CC=- AJ/(2.* SDH)* SIG
  8140.       JUNE= IEND
  8141.     6 IF( JCOX.EQ. I) GOTO 9
  8142.       IF( JEND.EQ.1) GOTO 7
  8143.       JCOX= ICON1( JCOX)
  8144.       GOTO 8
  8145.     7 JCOX= ICON2( JCOX)
  8146.     8 IF( IABS( JCOX).EQ. I) GOTO 10
  8147.       IF( JCOX) 1,24,2
  8148.     9 IF( JCOX.EQ. IS) BB=- BB
  8149.    10 IF( IEND.EQ.1) GOTO 12
  8150.    11 PM=- PP
  8151.       PP=0.
  8152.       NJUN1= JSNO
  8153.       JCOX= ICON2( I)
  8154.       IF( JCOX.GT.10000) JCOX= I
  8155.       JEND=1
  8156.       IEND=1
  8157.       SIG=-1.
  8158.       IF( JCOX) 1,12,2
  8159.    12 NJUN2= JSNO- NJUN1
  8160.       D= PI* SI( I)
  8161.       SDH= SIN( D)
  8162.       CDH= COS( D)
  8163.       SD=2.* SDH* CDH
  8164.       CD= CDH* CDH- SDH* SDH
  8165.       IF( D.GT.0.015) GOTO 13
  8166.       OMC=4.* D* D
  8167.       OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC
  8168.       GOTO 14
  8169.    13 OMC=1.- CD
  8170.    14 AP=1./( LOG(1./( PI* BI( I)))-.577215664D+0)
  8171.       AJ= AP
  8172.       IF( NJUN1.EQ.0) GOTO 19
  8173.       IF( NJUN2.EQ.0) GOTO 21
  8174.       QP= SD*( PM* PP+ AJ* AP)+ CD*( PM* AP- PP* AJ)
  8175.       QM=( AP* OMC- PP* SD)/ QP
  8176.       QP=-( AJ* OMC+ PM* SD)/ QP
  8177.       IF( JUNE) 15,18,16
  8178.    15 AA= AA* QM
  8179.       BB= BB* QM
  8180.       CC= CC* QM
  8181.       GOTO 17
  8182.    16 AA=- AA* QP
  8183.       BB= BB* QP
  8184.       CC=- CC* QP
  8185.    17 IF( I.NE. IS) RETURN
  8186.    18 AA= AA-1.
  8187.       BB= BB+( AJ* QM+ AP* QP)* SDH/ SD
  8188.       CC= CC+( AJ* QM- AP* QP)* CDH/ SD
  8189.       RETURN
  8190.    19 IF( NJUN2.EQ.0) GOTO 23
  8191.       QP= PI* BI( I)
  8192.       XXI= QP* QP
  8193.       XXI= QP*(1.-.5* XXI)/(1.- XXI)
  8194.       QP=-( OMC+ XXI* SD)/( SD*( AP+ XXI* PP)+ CD*( XXI* AP- PP))
  8195.       IF( JUNE.NE.1) GOTO 20
  8196.       AA=- AA* QP
  8197.       BB= BB* QP
  8198.       CC=- CC* QP
  8199.       IF( I.NE. IS) RETURN
  8200.    20 AA= AA-1.
  8201.       D= CD- XXI* SD
  8202.       BB= BB+( SDH+ AP* QP*( CDH- XXI* SDH))/ D
  8203.       CC= CC+( CDH+ AP* QP*( SDH+ XXI* CDH))/ D
  8204.       RETURN
  8205.    21 QM= PI* BI( I)
  8206.       XXI= QM* QM
  8207.       XXI= QM*(1.-.5* XXI)/(1.- XXI)
  8208.       QM=( OMC+ XXI* SD)/( SD*( AJ- XXI* PM)+ CD*( PM+ XXI* AJ))
  8209.       IF( JUNE.NE.-1) GOTO 22
  8210.       AA= AA* QM
  8211.       BB= BB* QM
  8212.       CC= CC* QM
  8213.       IF( I.NE. IS) RETURN
  8214.    22 AA= AA-1.
  8215.       D= CD- XXI* SD
  8216.       BB= BB+( AJ* QM*( CDH- XXI* SDH)- SDH)/ D
  8217.       CC= CC+( CDH- AJ* QM*( SDH+ XXI* CDH))/ D
  8218.       RETURN
  8219.    23 AA=-1.
  8220.       QP= PI* BI( I)
  8221.       XXI= QP* QP
  8222.       XXI= QP*(1.-.5* XXI)/(1.- XXI)
  8223.       CC=1./( CDH- XXI* SDH)
  8224.       RETURN
  8225.    24 WRITE( 6,25)  I
  8226. C                                                                       
  8227.       STOP
  8228.    25 FORMAT(' SBF - SEGMENT CONNECTION ERROR FOR SEGMENT',I5)
  8229.       END
  8230. C ***
  8231. C     DOUBLE PRECISION 6/4/85
  8232. C
  8233.       SUBROUTINE SFLDS( T, E)
  8234. C ***
  8235. C                                                                       
  8236. C     SFLDX RETURNS THE FIELD DUE TO GROUND FOR A CURRENT ELEMENT ON    
  8237. C     THE SOURCE SEGMENT AT T RELATIVE TO THE SEGMENT CENTER.           
  8238. C                                                                       
  8239.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  8240.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  8241.       COMPLEX  E, ERV, EZV, ERH, EZH, EPH, T1, EXK, EYK, EZK, EXS, 
  8242.      &EYS, EZS, EXC, EYC, EZC, XX1, XX2, U, U2, ZRATI, ZRATI2, FRATI, 
  8243.      &ER, ET, HRV, HZV, HRH
  8244.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  8245.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  8246.      &INDD2, IPGND
  8247.       COMMON  /INCOM/ XO, YO, ZO, SN, XSN, YSN, ISNOR
  8248.       COMMON  /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH
  8249.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  8250.      &KSYMP, IFAR, IPERF, T1, T2
  8251.       DIMENSION  E(9)
  8252.       DATA   PI/3.141592654D+0/, TP/6.283185308D+0/, POT/1.570796327D+0
  8253.      &/
  8254.       XT= XJ+ T* CABJ
  8255.       YT= YJ+ T* SABJ
  8256.       ZT= ZJ+ T* SALPJ
  8257.       RHX= XO- XT
  8258.       RHY= YO- YT
  8259.       RHS= RHX* RHX+ RHY* RHY
  8260.       RHO= SQRT( RHS)
  8261.       IF( RHO.GT.0.) GOTO 1
  8262.       RHX=1.
  8263.       RHY=0.
  8264.       PHX=0.
  8265.       PHY=1.
  8266.       GOTO 2
  8267.     1 RHX= RHX/ RHO
  8268.       RHY= RHY/ RHO
  8269.       PHX=- RHY
  8270.       PHY= RHX
  8271.     2 CPH= RHX* XSN+ RHY* YSN
  8272.       SPH= RHY* XSN- RHX* YSN
  8273.       IF( ABS( CPH).LT.1.D-10) CPH=0.
  8274.       IF( ABS( SPH).LT.1.D-10) SPH=0.
  8275.       ZPH= ZO+ ZT
  8276.       ZPHS= ZPH* ZPH
  8277.       R2S= RHS+ ZPHS
  8278.       R2= SQRT( R2S)
  8279.       RK= R2* TP
  8280.       XX2= CMPLX( COS( RK),- SIN( RK))
  8281. C                                                                       
  8282. C     USE NORTON APPROXIMATION FOR FIELD DUE TO GROUND.  CURRENT IS     
  8283. C     LUMPED AT SEGMENT CENTER WITH CURRENT MOMENT FOR CONSTANT, SINE,  
  8284. C     OR COSINE DISTRIBUTION.                                           
  8285. C                                                                       
  8286.       IF( ISNOR.EQ.1) GOTO 3
  8287.       ZMH=1.
  8288.       R1=1.
  8289.       XX1=0.
  8290.       CALL GWAVE( ERV, EZV, ERH, EZH, EPH)
  8291.       ET=-(0.,4.77134)* FRATI* XX2/( R2S* R2)
  8292.       ER=2.* ET* CMPLX(1.0, RK)
  8293.       ET= ET* CMPLX(1.0 - RK* RK, RK)
  8294.       HRV=( ER+ ET)* RHO* ZPH/ R2S
  8295.       HZV=( ZPHS* ER- RHS* ET)/ R2S
  8296.       HRH=( RHS* ER- ZPHS* ET)/ R2S
  8297.       ERV= ERV- HRV
  8298.       EZV= EZV- HZV
  8299.       ERH= ERH+ HRH
  8300.       EZH= EZH+ HRV
  8301.       EPH= EPH+ ET
  8302.       ERV= ERV* SALPJ
  8303.       EZV= EZV* SALPJ
  8304.       ERH= ERH* SN* CPH
  8305.       EZH= EZH* SN* CPH
  8306.       EPH= EPH* SN* SPH
  8307.       ERH= ERV+ ERH
  8308.       E(1)=( ERH* RHX+ EPH* PHX)* S
  8309.       E(2)=( ERH* RHY+ EPH* PHY)* S
  8310.       E(3)=( EZV+ EZH)* S
  8311.       E(4)=0.
  8312.       E(5)=0.
  8313.       E(6)=0.
  8314.       SFAC= PI* S
  8315.       SFAC= SIN( SFAC)/ SFAC
  8316.       E(7)= E(1)* SFAC
  8317.       E(8)= E(2)* SFAC
  8318.       E(9)= E(3)* SFAC
  8319. C                                                                       
  8320. C     INTERPOLATE IN SOMMERFELD FIELD TABLES                            
  8321. C                                                                       
  8322.       RETURN
  8323.     3 IF( RHO.LT.1.D-12) GOTO 4
  8324.       THET= ATAN( ZPH/ RHO)
  8325.       GOTO 5
  8326.     4 THET= POT
  8327. C     COMBINE VERTICAL AND HORIZONTAL COMPONENTS AND CONVERT TO X,Y,Z   
  8328. C     COMPONENTS.  MULTIPLY BY EXP(-JKR)/R.                             
  8329.     5 CALL INTRP( R2, THET, ERV, EZV, ERH, EPH)
  8330.       XX2= XX2/ R2
  8331.       SFAC= SN* CPH
  8332.       ERH= XX2*( SALPJ* ERV+ SFAC* ERH)
  8333.       EZH= XX2*( SALPJ* EZV- SFAC* ERV)
  8334. C     X,Y,Z FIELDS FOR CONSTANT CURRENT                                 
  8335.       EPH= SN* SPH* XX2* EPH
  8336.       E(1)= ERH* RHX+ EPH* PHX
  8337.       E(2)= ERH* RHY+ EPH* PHY
  8338.       E(3)= EZH
  8339. C     X,Y,Z FIELDS FOR SINE CURRENT                                     
  8340.       RK= TP* T
  8341.       SFAC= SIN( RK)
  8342.       E(4)= E(1)* SFAC
  8343.       E(5)= E(2)* SFAC
  8344. C     X,Y,Z FIELDS FOR COSINE CURRENT                                   
  8345.       E(6)= E(3)* SFAC
  8346.       SFAC= COS( RK)
  8347.       E(7)= E(1)* SFAC
  8348.       E(8)= E(2)* SFAC
  8349.       E(9)= E(3)* SFAC
  8350.       RETURN
  8351.       END
  8352. C ***
  8353. C     DOUBLE PRECISION 6/4/85
  8354. C
  8355.       SUBROUTINE SOLGF( A, B, C, D, XY, IP, NP, N1, N, MP, M1, M, N1C, 
  8356.      &N2C, N2CZ)
  8357. C ***
  8358. C     SOLVE FOR CURRENT IN N.G.F. PROCEDURE                             
  8359.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  8360.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  8361.       COMPLEX  A, B, C, D, SUM, XY, Y
  8362.       COMMON  /SCRATM/ Y( N2M)
  8363.       COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50), 
  8364.      &NSCON, IPCON(10), NPCON
  8365.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  8366.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  8367.       DIMENSION  A(1), B( N1C,1), C( N1C,1), D( N2CZ,1), IP(1), XY(1)
  8368.       IFL=14
  8369.       IF( ICASX.GT.0) IFL=13
  8370. C     NORMAL SOLUTION.  NOT N.G.F.                                      
  8371.       IF( N2C.GT.0) GOTO 1
  8372.       CALL SOLVES( A, IP, XY, N1C,1, NP, N, MP, M,13, IFL)
  8373.       GOTO 22
  8374. C     REORDER EXCITATION ARRAY                                          
  8375.     1 IF( N1.EQ. N.OR. M1.EQ.0) GOTO 5
  8376.       N2= N1+1
  8377.       JJ= N+1
  8378.       NPM= N+2* M1
  8379.       DO 2  I= N2, NPM
  8380.     2 Y( I)= XY( I)
  8381.       J= N1
  8382.       DO 3  I= JJ, NPM
  8383.       J= J+1
  8384.     3 XY( J)= Y( I)
  8385.       DO 4  I= N2, N
  8386.       J= J+1
  8387.     4 XY( J)= Y( I)
  8388.     5 NEQS= NSCON+2* NPCON
  8389.       IF( NEQS.EQ.0) GOTO 7
  8390.       NEQ= N1C+ N2C
  8391. C     COMPUTE INV(A)E1                                                  
  8392.       NEQS= NEQ- NEQS+1
  8393.       DO 6  I= NEQS, NEQ
  8394.     6 XY( I)=(0.,0.)
  8395.     7 CALL SOLVES( A, IP, XY, N1C,1, NP, N1, MP, M1,13, IFL)
  8396.       NI=0
  8397. C     COMPUTE E2-C(INV(A)E1)                                            
  8398.       NPB= NPBL
  8399.       DO 10  JJ=1, NBBL
  8400.       IF( JJ.EQ. NBBL) NPB= NLBL
  8401.       IF( ICASX.GT.1) READ( 15) (( C( I, J), I=1, N1C), J=1, NPB)
  8402.       II= N1C+ NI
  8403.       DO 9  I=1, NPB
  8404.       SUM=(0.,0.)
  8405.       DO 8  J=1, N1C
  8406.     8 SUM= SUM+ C( J, I)* XY( J)
  8407.       J= II+ I
  8408.     9 XY( J)= XY( J)- SUM
  8409.    10 NI= NI+ NPBL
  8410.       REWIND 15
  8411. C     COMPUTE INV(D)(E2-C(INV(A)E1)) = I2                               
  8412.       JJ= N1C+1
  8413.       IF( ICASX.GT.1) GOTO 11
  8414.       CALL SOLVE( N2C, D, IP( JJ), XY( JJ), N2C)
  8415.       GOTO 13
  8416.    11 IF( ICASX.EQ.4) GOTO 12
  8417.       NI= N2C* N2C
  8418.       READ( 11) ( B( J,1), J=1, NI)
  8419.       REWIND 11
  8420.       CALL SOLVE( N2C, B, IP( JJ), XY( JJ), N2C)
  8421.       GOTO 13
  8422.    12 NBLSYS= NBLSYM
  8423.       NPSYS= NPSYM
  8424.       NLSYS= NLSYM
  8425.       ICASS= ICASE
  8426.       NBLSYM= NBBL
  8427.       NPSYM= NPBL
  8428.       NLSYM= NLBL
  8429.       ICASE=3
  8430.       REWIND 11
  8431.       REWIND 16
  8432.       CALL LTSOLV( B, N2C, IP( JJ), XY( JJ), N2C,1,11,16)
  8433.       REWIND 11
  8434.       REWIND 16
  8435.       NBLSYM= NBLSYS
  8436.       NPSYM= NPSYS
  8437.       NLSYM= NLSYS
  8438.       ICASE= ICASS
  8439.    13 NI=0
  8440. C     COMPUTE INV(A)E1-(INV(A)B)I2 = I1                                 
  8441.       NPB= NPBL
  8442.       DO 16  JJ=1, NBBL
  8443.       IF( JJ.EQ. NBBL) NPB= NLBL
  8444.       IF( ICASX.GT.1) READ( 14) (( B( I, J), I=1, N1C), J=1, NPB)
  8445.       II= N1C+ NI
  8446.       DO 15  I=1, N1C
  8447.       SUM=(0.,0.)
  8448.       DO 14  J=1, NPB
  8449.       JP= II+ J
  8450.    14 SUM= SUM+ B( I, J)* XY( JP)
  8451.    15 XY( I)= XY( I)- SUM
  8452.    16 NI= NI+ NPBL
  8453.       REWIND 14
  8454. C     REORDER CURRENT ARRAY                                             
  8455.       IF( N1.EQ. N.OR. M1.EQ.0) GOTO 20
  8456.       DO 17  I= N2, NPM
  8457.    17 Y( I)= XY( I)
  8458.       JJ= N1C+1
  8459.       J= N1
  8460.       DO 18  I= JJ, NPM
  8461.       J= J+1
  8462.    18 XY( J)= Y( I)
  8463.       DO 19  I= N2, N1C
  8464.       J= J+1
  8465.    19 XY( J)= Y( I)
  8466.    20 IF( NSCON.EQ.0) GOTO 22
  8467.       J= NEQS-1
  8468.       DO 21  I=1, NSCON
  8469.       J= J+1
  8470.       JJ= ISCON( I)
  8471.    21 XY( JJ)= XY( J)
  8472.    22 RETURN
  8473.       END
  8474. C ***
  8475. C     DOUBLE PRECISION 6/4/85
  8476. C
  8477.       SUBROUTINE SOLVE( N, A, IP, B, NDIM)
  8478. C ***
  8479. C                                                                       
  8480. C     SUBROUTINE TO SOLVE THE MATRIX EQUATION LU*X=B WHERE L IS A UNIT  
  8481. C     LOWER TRIANGULAR MATRIX AND U IS AN UPPER TRIANGULAR MATRIX BOTH  
  8482. C     OF WHICH ARE STORED IN A.  THE RHS VECTOR B IS INPUT AND THE      
  8483. C     SOLUTION IS RETURNED THROUGH VECTOR B.    (MATRIX TRANSPOSED.     
  8484. C                                                                       
  8485.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  8486.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  8487.       COMPLEX  A, B, Y, SUM
  8488.       INTEGER  PI
  8489.       COMMON  /SCRATM/ Y( N2M)
  8490. C                                                                       
  8491. C     FORWARD SUBSTITUTION                                              
  8492. C                                                                       
  8493.       DIMENSION  A( NDIM, NDIM), IP( NDIM), B( NDIM)
  8494.       DO 3  I=1, N
  8495.       PI= IP( I)
  8496.       Y( I)= B( PI)
  8497.       B( PI)= B( I)
  8498.       IP1= I+1
  8499.       IF( IP1.GT. N) GOTO 2
  8500.       DO 1  J= IP1, N
  8501.       B( J)= B( J)- A( I, J)* Y( I)
  8502.     1 CONTINUE
  8503.     2 CONTINUE
  8504. C                                                                       
  8505. C     BACKWARD SUBSTITUTION                                             
  8506. C                                                                       
  8507.     3 CONTINUE
  8508.       DO 6  K=1, N
  8509.       I= N- K+1
  8510.       SUM=(0.,0.)
  8511.       IP1= I+1
  8512.       IF( IP1.GT. N) GOTO 5
  8513.       DO 4  J= IP1, N
  8514.       SUM= SUM+ A( J, I)* B( J)
  8515.     4 CONTINUE
  8516.     5 CONTINUE
  8517.       B( I)=( Y( I)- SUM)/ A( I, I)
  8518.     6 CONTINUE
  8519.       RETURN
  8520.       END
  8521. C ***
  8522. C     DOUBLE PRECISION 6/4/85
  8523. C
  8524.       SUBROUTINE SOLVES( A, IP, B, NEQ, NRH, NP, N, MP, M, IFL1, IFL2)
  8525. C ***
  8526. C                                                                       
  8527. C     SUBROUTINE SOLVES, FOR SYMMETRIC STRUCTURES, HANDLES THE          
  8528. C     TRANSFORMATION OF THE RIGHT HAND SIDE VECTOR AND SOLUTION OF THE  
  8529. C     MATRIX EQ.                                                        
  8530. C                                                                       
  8531.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  8532.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  8533.       COMPLEX  A, B, Y, SUM, SSX
  8534.       COMMON  /SMAT/ SSX(16,16)
  8535.       COMMON  /SCRATM/ Y( N2M)
  8536.       COMMON  /MATPAR/ ICASE, NBLOKS, NPBLK, NLAST, NBLSYM, NPSYM, 
  8537.      &NLSYM, IMAT, ICASX, NBBX, NPBX, NLBX, NBBL, NPBL, NLBL
  8538.       DIMENSION  A(1), IP(1), B( NEQ, NRH)
  8539.       NPEQ= NP+2* MP
  8540.       NOP= NEQ/ NPEQ
  8541.       FNOP= NOP
  8542.       FNORM=1./ FNOP
  8543.       NROW= NEQ
  8544.       IF( ICASE.GT.3) NROW= NPEQ
  8545.       IF( NOP.EQ.1) GOTO 11
  8546.       DO 10  IC=1, NRH
  8547.       IF( N.EQ.0.OR. M.EQ.0) GOTO 6
  8548.       DO 1  I=1, NEQ
  8549.     1 Y( I)= B( I, IC)
  8550.       KK=2* MP
  8551.       IA= NP
  8552.       IB= N
  8553.       J= NP
  8554.       DO 5  K=1, NOP
  8555.       IF( K.EQ.1) GOTO 3
  8556.       DO 2  I=1, NP
  8557.       IA= IA+1
  8558.       J= J+1
  8559.     2 B( J, IC)= Y( IA)
  8560.       IF( K.EQ. NOP) GOTO 5
  8561.     3 DO 4  I=1, KK
  8562.       IB= IB+1
  8563.       J= J+1
  8564.     4 B( J, IC)= Y( IB)
  8565. C                                                                       
  8566. C     TRANSFORM MATRIX EQ. RHS VECTOR ACCORDING TO SYMMETRY MODES       
  8567. C                                                                       
  8568.     5 CONTINUE
  8569.     6 DO 10  I=1, NPEQ
  8570.       DO 7  K=1, NOP
  8571.       IA= I+( K-1)* NPEQ
  8572.     7 Y( K)= B( IA, IC)
  8573.       SUM= Y(1)
  8574.       DO 8  K=2, NOP
  8575.     8 SUM= SUM+ Y( K)
  8576.       B( I, IC)= SUM* FNORM
  8577.       DO 10  K=2, NOP
  8578.       IA= I+( K-1)* NPEQ
  8579.       SUM= Y(1)
  8580.       DO 9  J=2, NOP
  8581.     9 SUM= SUM+ Y( J)* CONJG( SSX( K, J))
  8582.    10 B( IA, IC)= SUM* FNORM
  8583.    11 IF( ICASE.LT.3) GOTO 12
  8584.       REWIND IFL1
  8585. C                                                                       
  8586. C     SOLVE EACH MODE EQUATION                                          
  8587. C                                                                       
  8588.       REWIND IFL2
  8589.    12 DO 16  KK=1, NOP
  8590.       IA=( KK-1)* NPEQ+1
  8591.       IB= IA
  8592.       IF( ICASE.NE.4) GOTO 13
  8593.       I= NPEQ* NPEQ
  8594.       READ( IFL1) ( A( J), J=1, I)
  8595.       IB=1
  8596.    13 IF( ICASE.EQ.3.OR. ICASE.EQ.5) GOTO 15
  8597.       DO 14  IC=1, NRH
  8598.    14 CALL SOLVE( NPEQ, A( IB), IP( IA), B( IA, IC), NROW)
  8599.       GOTO 16
  8600.    15 CALL LTSOLV( A, NPEQ, IP( IA), B( IA,1), NEQ, NRH, IFL1, IFL2)
  8601.    16 CONTINUE
  8602. C                                                                       
  8603. C     INVERSE TRANSFORM THE MODE SOLUTIONS                              
  8604. C                                                                       
  8605.       IF( NOP.EQ.1) RETURN
  8606.       DO 26  IC=1, NRH
  8607.       DO 20  I=1, NPEQ
  8608.       DO 17  K=1, NOP
  8609.       IA= I+( K-1)* NPEQ
  8610.    17 Y( K)= B( IA, IC)
  8611.       SUM= Y(1)
  8612.       DO 18  K=2, NOP
  8613.    18 SUM= SUM+ Y( K)
  8614.       B( I, IC)= SUM
  8615.       DO 20  K=2, NOP
  8616.       IA= I+( K-1)* NPEQ
  8617.       SUM= Y(1)
  8618.       DO 19  J=2, NOP
  8619.    19 SUM= SUM+ Y( J)* SSX( K, J)
  8620.    20 B( IA, IC)= SUM
  8621.       IF( N.EQ.0.OR. M.EQ.0) GOTO 26
  8622.       DO 21  I=1, NEQ
  8623.    21 Y( I)= B( I, IC)
  8624.       KK=2* MP
  8625.       IA= NP
  8626.       IB= N
  8627.       J= NP
  8628.       DO 25  K=1, NOP
  8629.       IF( K.EQ.1) GOTO 23
  8630.       DO 22  I=1, NP
  8631.       IA= IA+1
  8632.       J= J+1
  8633.    22 B( IA, IC)= Y( J)
  8634.       IF( K.EQ. NOP) GOTO 25
  8635.    23 DO 24  I=1, KK
  8636.       IB= IB+1
  8637.       J= J+1
  8638.    24 B( IB, IC)= Y( J)
  8639.    25 CONTINUE
  8640.    26 CONTINUE
  8641.       RETURN
  8642.       END
  8643. C ***
  8644. C     DOUBLE PRECISION 6/4/85
  8645. C
  8646.       SUBROUTINE TBF( I, ICAP)
  8647. C ***
  8648. C     COMPUTE BASIS FUNCTION I                                          
  8649.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  8650.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  8651.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  8652.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  8653.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  8654.       COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50), 
  8655.      &NSCON, IPCON(10), NPCON
  8656.       DATA   PI/3.141592654D+0/, JMAX/30/
  8657.       JSNO=0
  8658.       PP=0.
  8659.       JCOX= ICON1( I)
  8660.       IF( JCOX.GT.10000) JCOX= I
  8661.       JEND=-1
  8662.       IEND=-1
  8663.       SIG=-1.
  8664.       IF( JCOX) 1,10,2
  8665.     1 JCOX=- JCOX
  8666.       GOTO 3
  8667.     2 SIG=- SIG
  8668.       JEND=- JEND
  8669.     3 JSNO= JSNO+1
  8670.       IF( JSNO.GE. JMAX) GOTO 28
  8671.       JCO( JSNO)= JCOX
  8672.       D= PI* SI( JCOX)
  8673.       SDH= SIN( D)
  8674.       CDH= COS( D)
  8675.       SD=2.* SDH* CDH
  8676.       IF( D.GT.0.015) GOTO 4
  8677.       OMC=4.* D* D
  8678.       OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC
  8679.       GOTO 5
  8680.     4 OMC=1.- CDH* CDH+ SDH* SDH
  8681.     5 AJ=1./( LOG(1./( PI* BI( JCOX)))-.577215664D+0)
  8682.       PP= PP- OMC/ SD* AJ
  8683.       AX( JSNO)= AJ/ SD* SIG
  8684.       BX( JSNO)= AJ/(2.* CDH)
  8685.       CX( JSNO)=- AJ/(2.* SDH)* SIG
  8686.       IF( JCOX.EQ. I) GOTO 8
  8687.       IF( JEND.EQ.1) GOTO 6
  8688.       JCOX= ICON1( JCOX)
  8689.       GOTO 7
  8690.     6 JCOX= ICON2( JCOX)
  8691.     7 IF( IABS( JCOX).EQ. I) GOTO 9
  8692.       IF( JCOX) 1,28,2
  8693.     8 BX( JSNO)=- BX( JSNO)
  8694.     9 IF( IEND.EQ.1) GOTO 11
  8695.    10 PM=- PP
  8696.       PP=0.
  8697.       NJUN1= JSNO
  8698.       JCOX= ICON2( I)
  8699.       IF( JCOX.GT.10000) JCOX= I
  8700.       JEND=1
  8701.       IEND=1
  8702.       SIG=-1.
  8703.       IF( JCOX) 1,11,2
  8704.    11 NJUN2= JSNO- NJUN1
  8705.       JSNOP= JSNO+1
  8706.       JCO( JSNOP)= I
  8707.       D= PI* SI( I)
  8708.       SDH= SIN( D)
  8709.       CDH= COS( D)
  8710.       SD=2.* SDH* CDH
  8711.       CD= CDH* CDH- SDH* SDH
  8712.       IF( D.GT.0.015) GOTO 12
  8713.       OMC=4.* D* D
  8714.       OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC
  8715.       GOTO 13
  8716.    12 OMC=1.- CD
  8717.    13 AP=1./( LOG(1./( PI* BI( I)))-.577215664D+0)
  8718.       AJ= AP
  8719.       IF( NJUN1.EQ.0) GOTO 16
  8720.       IF( NJUN2.EQ.0) GOTO 20
  8721.       QP= SD*( PM* PP+ AJ* AP)+ CD*( PM* AP- PP* AJ)
  8722.       QM=( AP* OMC- PP* SD)/ QP
  8723.       QP=-( AJ* OMC+ PM* SD)/ QP
  8724.       BX( JSNOP)=( AJ* QM+ AP* QP)* SDH/ SD
  8725.       CX( JSNOP)=( AJ* QM- AP* QP)* CDH/ SD
  8726.       DO 14  IEND=1, NJUN1
  8727.       AX( IEND)= AX( IEND)* QM
  8728.       BX( IEND)= BX( IEND)* QM
  8729.    14 CX( IEND)= CX( IEND)* QM
  8730.       JEND= NJUN1+1
  8731.       DO 15  IEND= JEND, JSNO
  8732.       AX( IEND)=- AX( IEND)* QP
  8733.       BX( IEND)= BX( IEND)* QP
  8734.    15 CX( IEND)=- CX( IEND)* QP
  8735.       GOTO 27
  8736.    16 IF( NJUN2.EQ.0) GOTO 24
  8737.       IF( ICAP.NE.0) GOTO 17
  8738.       XXI=0.
  8739.       GOTO 18
  8740.    17 QP= PI* BI( I)
  8741.       XXI= QP* QP
  8742.       XXI= QP*(1.-.5* XXI)/(1.- XXI)
  8743.    18 QP=-( OMC+ XXI* SD)/( SD*( AP+ XXI* PP)+ CD*( XXI* AP- PP))
  8744.       D= CD- XXI* SD
  8745.       BX( JSNOP)=( SDH+ AP* QP*( CDH- XXI* SDH))/ D
  8746.       CX( JSNOP)=( CDH+ AP* QP*( SDH+ XXI* CDH))/ D
  8747.       DO 19  IEND=1, NJUN2
  8748.       AX( IEND)=- AX( IEND)* QP
  8749.       BX( IEND)= BX( IEND)* QP
  8750.    19 CX( IEND)=- CX( IEND)* QP
  8751.       GOTO 27
  8752.    20 IF( ICAP.NE.0) GOTO 21
  8753.       XXI=0.
  8754.       GOTO 22
  8755.    21 QM= PI* BI( I)
  8756.       XXI= QM* QM
  8757.       XXI= QM*(1.-.5* XXI)/(1.- XXI)
  8758.    22 QM=( OMC+ XXI* SD)/( SD*( AJ- XXI* PM)+ CD*( PM+ XXI* AJ))
  8759.       D= CD- XXI* SD
  8760.       BX( JSNOP)=( AJ* QM*( CDH- XXI* SDH)- SDH)/ D
  8761.       CX( JSNOP)=( CDH- AJ* QM*( SDH+ XXI* CDH))/ D
  8762.       DO 23  IEND=1, NJUN1
  8763.       AX( IEND)= AX( IEND)* QM
  8764.       BX( IEND)= BX( IEND)* QM
  8765.    23 CX( IEND)= CX( IEND)* QM
  8766.       GOTO 27
  8767.    24 BX( JSNOP)=0.
  8768.       IF( ICAP.NE.0) GOTO 25
  8769.       XXI=0.
  8770.       GOTO 26
  8771.    25 QP= PI* BI( I)
  8772.       XXI= QP* QP
  8773.       XXI= QP*(1.-.5* XXI)/(1.- XXI)
  8774.    26 CX( JSNOP)=1./( CDH- XXI* SDH)
  8775.    27 JSNO= JSNOP
  8776.       AX( JSNO)=-1.
  8777.       RETURN
  8778.    28 WRITE( 6,29)  I
  8779. C                                                                       
  8780.       STOP
  8781.    29 FORMAT(' TBF - SEGMENT CONNECTION ERROR FOR SEGMENT',I5)
  8782.       END
  8783. C ***
  8784. C     DOUBLE PRECISION 6/4/85
  8785. C
  8786.       SUBROUTINE TEST( F1R, F2R, TR, F1I, F2I, TI, DMIN)
  8787. C ***
  8788. C                                                                       
  8789. C     TEST FOR CONVERGENCE IN NUMERICAL INTEGRATION                     
  8790. C                                                                       
  8791.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  8792.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  8793.       DEN= ABS( F2R)
  8794.       TR= ABS( F2I)
  8795.       IF( DEN.LT. TR) DEN= TR
  8796.       IF( DEN.LT. DMIN) DEN= DMIN
  8797.       IF( DEN.LT.1.D-37) GOTO 1
  8798.       TR= ABS(( F1R- F2R)/ DEN)
  8799.       TI= ABS(( F1I- F2I)/ DEN)
  8800.       RETURN
  8801.     1 TR=0.
  8802.       TI=0.
  8803.       RETURN
  8804.       END
  8805. C ***
  8806. C     DOUBLE PRECISION 6/4/85
  8807. C
  8808.       SUBROUTINE TRIO( J)
  8809. C ***
  8810. C     COMPUTE THE COMPONENTS OF ALL BASIS FUNCTIONS ON SEGMENT J        
  8811.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  8812.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  8813.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  8814.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  8815.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  8816.       COMMON  /SEGJ/ AX(30), BX(30), CX(30), JCO(30), JSNO, ISCON(50), 
  8817.      &NSCON, IPCON(10), NPCON
  8818.       DATA   JMAX/30/
  8819.       JSNO=0
  8820.       JCOX= ICON1( J)
  8821.       IF( JCOX.GT.10000) GOTO 7
  8822.       JEND=-1
  8823.       IEND=-1
  8824.       IF( JCOX) 1,7,2
  8825.     1 JCOX=- JCOX
  8826.       GOTO 3
  8827.     2 JEND=- JEND
  8828.     3 IF( JCOX.EQ. J) GOTO 6
  8829.       JSNO= JSNO+1
  8830.       IF( JSNO.GE. JMAX) GOTO 9
  8831.       CALL SBF( JCOX, J, AX( JSNO), BX( JSNO), CX( JSNO))
  8832.       JCO( JSNO)= JCOX
  8833.       IF( JEND.EQ.1) GOTO 4
  8834.       JCOX= ICON1( JCOX)
  8835.       GOTO 5
  8836.     4 JCOX= ICON2( JCOX)
  8837.     5 IF( JCOX) 1,9,2
  8838.     6 IF( IEND.EQ.1) GOTO 8
  8839.     7 JCOX= ICON2( J)
  8840.       IF( JCOX.GT.10000) GOTO 8
  8841.       JEND=1
  8842.       IEND=1
  8843.       IF( JCOX) 1,8,2
  8844.     8 JSNO= JSNO+1
  8845.       CALL SBF( J, J, AX( JSNO), BX( JSNO), CX( JSNO))
  8846.       JCO( JSNO)= J
  8847.       RETURN
  8848.     9 WRITE( 6,10)  J
  8849. C                                                                       
  8850.       STOP
  8851.    10 FORMAT(' TRIO - SEGMENT CONNENTION ERROR FOR SEGMENT',I5)
  8852.       END
  8853. C ***
  8854. C     DOUBLE PRECISION 6/4/85
  8855. C
  8856.       SUBROUTINE UNERE( XOB, YOB, ZOB)
  8857. C ***
  8858. C     CALCULATES THE ELECTRIC FIELD DUE TO UNIT CURRENT IN THE T1 AND T2
  8859. C     DIRECTIONS ON A PATCH                                             
  8860.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  8861.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  8862.       COMPLEX  EXK, EYK, EZK, EXS, EYS, EZS, EXC, EYC, EZC, ZRATI, 
  8863.      &ZRATI2, T1, ER, Q1, Q2, RRV, RRH, EDP, FRATI
  8864.       COMMON  /DATAJ/ S, B, XJ, YJ, ZJ, CABJ, SABJ, SALPJ, EXK, EYK, 
  8865.      &EZK, EXS, EYS, EZS, EXC, EYC, EZC, RKH, IEXK, IND1, INDD1, IND2, 
  8866.      &INDD2, IPGND
  8867.       COMMON  /GND/ ZRATI, ZRATI2, FRATI, CL, CH, SCRWL, SCRWR, NRADL, 
  8868.      &KSYMP, IFAR, IPERF, T1, T2
  8869.       EQUIVALENCE(T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2YJ,
  8870.      &IND1),(T2ZJ,IND2)
  8871. C     CONST=ETA/(8.*PI**2)                                              
  8872.       DATA   TPI, CONST/6.283185308D+0,4.771341188D+0/
  8873.       ZR= ZJ
  8874.       T1ZR= T1ZJ
  8875.       T2ZR= T2ZJ
  8876.       IF( IPGND.NE.2) GOTO 1
  8877.       ZR=- ZR
  8878.       T1ZR=- T1ZR
  8879.       T2ZR=- T2ZR
  8880.     1 RX= XOB- XJ
  8881.       RY= YOB- YJ
  8882.       RZ= ZOB- ZR
  8883.       R2= RX* RX+ RY* RY+ RZ* RZ
  8884.       IF( R2.GT.1.D-20) GOTO 2
  8885.       EXK=(0.,0.)
  8886.       EYK=(0.,0.)
  8887.       EZK=(0.,0.)
  8888.       EXS=(0.,0.)
  8889.       EYS=(0.,0.)
  8890.       EZS=(0.,0.)
  8891.       RETURN
  8892.     2 R= SQRT( R2)
  8893.       TT1=- TPI* R
  8894.       TT2= TT1* TT1
  8895.       RT= R2* R
  8896.       ER= CMPLX( SIN( TT1),- COS( TT1))*( CONST* S)
  8897.       Q1= CMPLX( TT2-1., TT1)* ER/ RT
  8898.       Q2= CMPLX(3.- TT2,-3.* TT1)* ER/( RT* R2)
  8899.       ER= Q2*( T1XJ* RX+ T1YJ* RY+ T1ZR* RZ)
  8900.       EXK= Q1* T1XJ+ ER* RX
  8901.       EYK= Q1* T1YJ+ ER* RY
  8902.       EZK= Q1* T1ZR+ ER* RZ
  8903.       ER= Q2*( T2XJ* RX+ T2YJ* RY+ T2ZR* RZ)
  8904.       EXS= Q1* T2XJ+ ER* RX
  8905.       EYS= Q1* T2YJ+ ER* RY
  8906.       EZS= Q1* T2ZR+ ER* RZ
  8907.       IF( IPGND.EQ.1) GOTO 6
  8908.       IF( IPERF.NE.1) GOTO 3
  8909.       EXK=- EXK
  8910.       EYK=- EYK
  8911.       EZK=- EZK
  8912.       EXS=- EXS
  8913.       EYS=- EYS
  8914.       EZS=- EZS
  8915.       GOTO 6
  8916.     3 XYMAG= SQRT( RX* RX+ RY* RY)
  8917.       IF( XYMAG.GT.1.D-6) GOTO 4
  8918.       PX=0.
  8919.       PY=0.
  8920.       CTH=1.
  8921.       RRV=(1.,0.)
  8922.       GOTO 5
  8923.     4 PX=- RY/ XYMAG
  8924.       PY= RX/ XYMAG
  8925.       CTH= RZ/ SQRT( XYMAG* XYMAG+ RZ* RZ)
  8926.       RRV= SQRT(1.- ZRATI* ZRATI*(1.- CTH* CTH))
  8927.     5 RRH= ZRATI* CTH
  8928.       RRH=( RRH- RRV)/( RRH+ RRV)
  8929.       RRV= ZRATI* RRV
  8930.       RRV=-( CTH- RRV)/( CTH+ RRV)
  8931.       EDP=( EXK* PX+ EYK* PY)*( RRH- RRV)
  8932.       EXK= EXK* RRV+ EDP* PX
  8933.       EYK= EYK* RRV+ EDP* PY
  8934.       EZK= EZK* RRV
  8935.       EDP=( EXS* PX+ EYS* PY)*( RRH- RRV)
  8936.       EXS= EXS* RRV+ EDP* PX
  8937.       EYS= EYS* RRV+ EDP* PY
  8938.       EZS= EZS* RRV
  8939.     6 RETURN
  8940.       END
  8941. C ***
  8942. C     DOUBLE PRECISION 6/4/85
  8943. C
  8944.       SUBROUTINE WIRE( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, RDEL, RRAD, 
  8945.      &NS, ITG)
  8946. C ***
  8947. C                                                                       
  8948. C     SUBROUTINE WIRE GENERATES SEGMENT GEOMETRY DATA FOR A STRAIGHT    
  8949. C     WIRE OF NS SEGMENTS.                                              
  8950. C                                                                       
  8951.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  8952.       PARAMETER ( NM=600, N2M=800, N3M=1000)
  8953.       COMMON  /DATA/ X( NM), Y( NM), Z( NM), SI( NM), BI( NM), ALP( NM),
  8954.      & BET( NM), WLAM, ICON1( N2M), ICON2(N2M), ITAG( N2M), ICONX( NM), 
  8955.      & IPSYM ,LD, N1, N2, N, NP, M1, M2, M, MP
  8956.       DIMENSION  X2(1), Y2(1), Z2(1)
  8957.       EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1))
  8958.       IST= N+1
  8959.       N= N+ NS
  8960.       NP= N
  8961.       MP= M
  8962.       IPSYM=0
  8963.       IF( NS.LT.1) RETURN
  8964.       XD= XW2- XW1
  8965.       YD= YW2- YW1
  8966.       ZD= ZW2- ZW1
  8967.       IF( ABS( RDEL-1.).LT.1.D-6) GOTO 1
  8968.       DELZ= SQRT( XD* XD+ YD* YD+ ZD* ZD)
  8969.       XD= XD/ DELZ
  8970.       YD= YD/ DELZ
  8971.       ZD= ZD/ DELZ
  8972.       DELZ= DELZ*(1.- RDEL)/(1.- RDEL** NS)
  8973.       RD= RDEL
  8974.       GOTO 2
  8975.     1 FNS= NS
  8976.       XD= XD/ FNS
  8977.       YD= YD/ FNS
  8978.       ZD= ZD/ FNS
  8979.       DELZ=1.
  8980.       RD=1.
  8981.     2 RADZ= RAD
  8982.       XS1= XW1
  8983.       YS1= YW1
  8984.       ZS1= ZW1
  8985.       DO 3  I= IST, N
  8986.       ITAG( I)= ITG
  8987.       XS2= XS1+ XD* DELZ
  8988.       YS2= YS1+ YD* DELZ
  8989.       ZS2= ZS1+ ZD* DELZ
  8990.       X( I)= XS1
  8991.       Y( I)= YS1
  8992.       Z( I)= ZS1
  8993.       X2( I)= XS2
  8994.       Y2( I)= YS2
  8995.       Z2( I)= ZS2
  8996.       BI( I)= RADZ
  8997.       DELZ= DELZ* RD
  8998.       RADZ= RADZ* RRAD
  8999.       XS1= XS2
  9000.       YS1= YS2
  9001.     3 ZS1= ZS2
  9002.       X2( N)= XW2
  9003.       Y2( N)= YW2
  9004.       Z2( N)= ZW2
  9005.       RETURN
  9006.       END
  9007. C ***
  9008. C     DOUBLE PRECISION 6/4/85
  9009. C
  9010.       FUNCTION ZINT( SIGL, ROLAM)
  9011. C ***
  9012. C                                                                       
  9013. C     ZINT COMPUTES THE INTERNAL IMPEDANCE OF A CIRCULAR WIRE           
  9014. C                                                                       
  9015. C                                                                       
  9016.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  9017.       COMPLEX  TH, PH, F, G, FJ, CN, BR1, BR2, ZINT
  9018.       COMPLEX  CC1, CC2, CC3, CC4, CC5, CC6, CC7, CC8, CC9, CC10, 
  9019.      &CC11, CC12, CC13, CC14
  9020.       DIMENSION  FJX(2), CNX(2), CCN(28)
  9021.       EQUIVALENCE(FJ,FJX),(CN,CNX),(CC1,CCN(1)),(CC2,CCN(3)),(CC3,CCN(5
  9022.      &)),(CC4,CCN(7)),(CC5,CCN(9)),(CC6,CCN(11)),(CC7,CCN(13)),(CC8,CCN
  9023.      &(15)),(CC9,CCN(17)),(CC10,CCN(19)),(CC11,CCN(21)),(CC12,CCN(23)),
  9024.      &(CC13,CCN(25)),(CC14,CCN(27))
  9025.       DATA   PI, POT, TP, TPCMU/3.1415926D+0,1.5707963D+0,6.2831853D+0,
  9026.      &2.368705D+3/
  9027.       DATA   CMOTP/60.00/, FJX/0.,1./, CNX/.70710678D+0,.70710678D+0/
  9028.       DATA   CCN/6.D-7,1.9D-6,-3.4D-6,5.1D-6,-2.52D-5,0.,-9.06D-5,-
  9029.      &9.01D-5,0.,-9.765D-4,.0110486D+0,-.0110485D+0,0.,-.3926991D+0,
  9030.      &1.6D-6,-3.2D-6,1.17D-5,-2.4D-6,3.46D-5,3.38D-5,5.D-7,2.452D-4,-
  9031.      &1.3813D-3,1.3811D-3,-6.25001D-2,-1.D-7,.7071068D+0,.7071068D+0/
  9032.       TH( D)=((((( CC1* D+ CC2)* D+ CC3)* D+ CC4)* D+ CC5)* D+ CC6)* D+
  9033.      & CC7
  9034.       PH( D)=((((( CC8* D+ CC9)* D+ CC10)* D+ CC11)* D+ CC12)* D+ CC13)
  9035.      &* D+ CC14
  9036.       F( D)= SQRT( POT/ D)* EXP(- CN* D+ TH(-8./ X))
  9037.       G( D)= EXP( CN* D+ TH(8./ X))/ SQRT( TP* D)
  9038.       X= SQRT( TPCMU* SIGL)* ROLAM
  9039.       IF( X.GT.110.) GOTO 2
  9040.       IF( X.GT.8.) GOTO 1
  9041.       Y= X/8.
  9042.       Y= Y* Y
  9043.       S= Y* Y
  9044.       BER=((((((-9.01D-6* S+1.22552D-3)* S-.08349609D+0)* S+
  9045.      &2.6419140D+0)* S-32.363456D+0)* S+113.77778D+0)* S-64.)* S+1.
  9046.       BEI=((((((1.1346D-4* S-.01103667D+0)* S+.52185615D+0)* S-
  9047.      &10.567658D+0)* S+72.817777D+0)* S-113.77778D+0)* S+16.)* Y
  9048.       BR1= CMPLX( BER, BEI)
  9049.       BER=(((((((-3.94D-6* S+4.5957D-4)* S-.02609253D+0)* S+
  9050.      &.66047849D+0)* S-6.0681481D+0)* S+14.222222D+0)* S-4.)* Y)* X
  9051.       BEI=((((((4.609D-5* S-3.79386D-3)* S+.14677204D+0)* S-
  9052.      &2.3116751D+0)* S+11.377778D+0)* S-10.666667D+0)* S+.5)* X
  9053.       BR2= CMPLX( BER, BEI)
  9054.       BR1= BR1/ BR2
  9055.       GOTO 3
  9056.     1 BR2= FJ* F( X)/ PI
  9057.       BR1= G( X)+ BR2
  9058.       BR2= G( X)* PH(8./ X)- BR2* PH(-8./ X)
  9059.       BR1= BR1/ BR2
  9060.       GOTO 3
  9061.     2 BR1= CMPLX(.70710678D+0,-.70710678D+0)
  9062.     3 ZINT= FJ* SQRT( CMOTP/ SIGL)* BR1/ ROLAM
  9063.       RETURN
  9064.       END
  9065.  
  9066.       SUBROUTINE STR0PC( STRING, STRING1)
  9067.       CHARACTER *(*)  STRING, STRING1
  9068.       INTEGER*4  I, J, IC
  9069.       DO 150, I=1, LEN( STRING)
  9070.       IC= ICHAR( STRING( I: I))
  9071.       IF( IC.GE.97.AND. IC.LE.122) IC= IC-32
  9072.       STRING1( I: I)= CHAR( IC)
  9073.   150 CONTINUE
  9074.       RETURN
  9075.       END
  9076.  
  9077.