1C PROGRAM NEC(INPUT,TAPE5=INPUT,OUTPUT,TAPE11,TAPE12,TAPE13,TAPE14, 2C 1TAPE15,TAPE16,TAPE20,TAPE21) 3C 4C NUMERICAL ELECTROMAGNETICS CODE (NEC2) DEVELOPED AT LAWRENCE 5C LIVERMORE LAB., LIVERMORE, CA. (CONTACT G. BURKE AT 510-422-8414 6C FOR PROBLEMS WITH THE NEC CODE.) 7C FILE CREATED 4/11/80. 8C 9C ***********NOTICE********** 10C THIS COMPUTER CODE MATERIAL WAS PREPARED AS AN ACCOUNT OF WORK 11C SPONSORED BY THE UNITED STATES GOVERNMENT. NEITHER THE UNITED 12C STATES NOR THE UNITED STATES DEPARTMENT OF ENERGY, NOR ANY OF 13C THEIR EMPLOYEES, NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR 14C THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 15C ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 16C COMPLETENESS OR USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT 17C OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT 18C INFRINGE PRIVATELY-OWNED RIGHTS. 19C 20C DOUBLE PRECISION 6/4/85 21C 22 PARAMETER (MAXSEG=1500, MAXMAT=1500) 23 PARAMETER (IRESRV=MAXMAT**2) 24 IMPLICIT REAL*8(A-H,O-Z) 25 CHARACTER AIN*2,ATST*2,INFILE*80,OUTFILE*80 26C*** 27 REAL*8 HPOL,PNET 28C CHARACTER INMSG*48,OUTMSG*40 29C INTEGER*2 GPWNXY(2) 30C LOGICAL*4 GetPut,LGTPT 31 COMPLEX*16 CM,FJ,VSANT,ETH,EPH,ZRATI,CUR,CURI,ZARRAY,ZRATI2 32 COMPLEX*16 EX,EY,EZ,ZPED,VQD,VQDS,T1,Y11A,Y12A,EPSC,U,U2,XX1,XX2 33 COMPLEX*16 AR1,AR2,AR3,EPSCF,FRATI 34 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 35 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 36 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 37 COMMON /CMB/CM(IRESRV) 38 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT, 39 1ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 40 COMMON/SAVE/EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(2*MAXSEG),KCOM 41 COMMON/CSAVE/COM(19,5) 42 COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG), 43 &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG) 44 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 45 &KSYMP,IFAR,IPERF 46 COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF 47 COMMON/YPARM/Y11A(5),Y12A(20),NCOUP,ICOUP,NCTAG(5),NCSEG(5) 48 COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON, 49 1IPCON(10),NPCON 50 COMMON/VSORC/VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30), 51 1IQDS(30),NVQD,NSANT,NQDS 52 COMMON/NETCX/ZPED,PIN,PNLS,X11R(30),X11I(30),X12R(30),X12I(30), 53 &X22R(30),X22I(30),NTYP(30),ISEG1(30),ISEG2(30),NEQ,NPEQ,NEQ2, 54 &NONET,NTSOL,NPRINT,MASYM 55 COMMON/FPAT/THETS,PHIS,DTH,DPH,RFLD,GNOR,CLT,CHT,EPSR2,SIG2, 56 &XPR6,PINR,PNLR,PLOSS,XNR,YNR,ZNR,DXNR,DYNR,DZNR,NTH,NPH,IPD,IAVP, 57 &INOR,IAX,IXTYP,NEAR,NFEH,NRX,NRY,NRZ 58 COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3), 59 1DYA(3),XSA(3),YSA(3),NXA(3),NYA(3) 60 COMMON/GWAV/U,U2,XX1,XX2,R1,R2,ZMH,ZPH 61C*** 62 COMMON /PLOT/ IPLP1,IPLP2,IPLP3,IPLP4 63C*** 64 DIMENSION CAB(1),SAB(1),X2(1),Y2(1),Z2(1) 65 DIMENSION LDTYP(30),LDTAG(30),LDTAGF(30),LDTAGT(30),ZLR(30), 66 1ZLI(30),ZLC(30) 67 DIMENSION ATST(22),PNET(6),HPOL(3),IX(2*MAXSEG) 68 DIMENSION FNORM(200) 69 DIMENSION T1X(1),T1Y(1),T1Z(1),T2X(1),T2Y(1),T2Z(1) 70C*** 71 DIMENSION XTEMP(MAXSEG),YTEMP(MAXSEG),ZTEMP(MAXSEG), 72 &SITEMP(MAXSEG),BITEMP(MAXSEG) 73 EQUIVALENCE (CAB,ALP),(SAB,BET),(X2,SI),(Y2,ALP),(Z2,BET) 74 EQUIVALENCE (T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2), 75 1 (T2Z,ITAG) 76 DATA ATST/'CE','FR','LD','GN','EX','NT','XQ','NE','GD','RP','CM', 77 1 'NX','EN','TL','PT','KH','NH','PQ','EK','WG','CP','PL'/ 78 DATA HPOL/6HLINEAR,5HRIGHT,4HLEFT/ 79 DATA PNET/6H ,2H ,6HSTRAIG,2HHT,6HCROSSE,1HD/ 80 DATA TA/1.745329252D-02/,CVEL/299.8/ 81 DATA LOADMX,NSMAX,NETMX/30,30,30/,NORMF/200/ 82706 CONTINUE 83C 84C History: 85C Date Change 86C ------- ---------------------------------------------- 87C 5/04/95 Matrix re-transposed in subroutine FACTR. 88C FACTR and SOLVE changed for non-transposed matrix. 89C 90C***VAX 91 WRITE(*,700) 92700 FORMAT(' ENTER NAME OF INPUT FILE >',$) 93701 FORMAT(A) 94 READ(*,701,ERR=702) INFILE 95C IF(INFILE.EQ.' ')INFILE='SYS$INPUT' 96 OPEN (UNIT=2,FILE=INFILE,STATUS='OLD',ERR=702) 97C OPEN (UNIT=2,FILE=INFILE,STATUS='OLD',ACTION='READ',ERR=702) 98C OPEN (UNIT=2,FILE=INFILE,STATUS='OLD',READONLY,ERR=702) 99707 CONTINUE 100 WRITE(*,703) 101703 FORMAT(' ENTER NAME OF OUTPUT FILE >',$) 102 READ(*,701,ERR=704) OUTFILE 103C IF(OUTFILE.EQ.' ')OUTFILE='SYS$OUTPUT' 104C OPEN (UNIT=3,FILE=OUTFILE,STATUS='NEW',ERR=704) 105 OPEN (UNIT=3,FILE=OUTFILE,STATUS='UNKNOWN',ERR=704) 106 GO TO 705 107702 CALL ERROR 108 GO TO 706 109704 CALL ERROR 110 GO TO 707 111C***MAC 112C OPEN IN AND OUT FILES WITH DIALOG BOX FOR MACINTOSH 113C 114C INMSG='Select nec input file (NEC-2D) ' 115C OUTMSG='Enter name of output file ' 116C GPWNXY(1)=50 117C GPWNXY(2)=100 118C702 LGTPT= GetPut(1,GPWNXY,INMSG,INFILE,IVOL,1,'TEXT') 119C IF(.NOT.LGTPT)STOP 120C OPEN (UNIT=2,FILE=INFILE,STATUS='OLD',ACTION='READ',ERR=702) 121C704 LGTPT= GetPut(0,GPWNXY,OUTMSG,OUTFILE,IVOL,1,'TEXT') 122C IF(.NOT.LGTPT)STOP 123C OPEN (UNIT=3,FILE=OUTFILE,STATUS='UNKNOWN',ERR=704) 124C WRITE(*,*)' NEC-2D RUN IN PROGRESS' 125C***MAC 126705 CONTINUE 127 CALL SECONDS(EXTIM) 128 FJ=(0.,1.) 129 LD=MAXSEG 1301 KCOM=0 131C*** 132 IFRTIMW=0 133 IFRTIMP=0 134C*** 1352 KCOM=KCOM+1 136 IF (KCOM.GT.5) KCOM=5 137 READ(2,125)AIN,(COM(I,KCOM),I=1,19) 138 CALL UPCASE(AIN,AIN,LAIN) 139 IF(KCOM.GT.1)GO TO 3 140 WRITE(3,126) 141 WRITE(3,127) 142 WRITE(3,128) 1433 WRITE(3,129) (COM(I,KCOM),I=1,19) 144 IF (AIN.EQ.ATST(11)) GO TO 2 145 IF (AIN.EQ.ATST(1)) GO TO 4 146 WRITE(3,130) 147 STOP 1484 CONTINUE 149 DO 5 I=1,LD 1505 ZARRAY(I)=(0.,0.) 151 MPCNT=0 152 IMAT=0 153C 154C SET UP GEOMETRY DATA IN SUBROUTINE DATAGN 155C 156 CALL DATAGN 157 IFLOW=1 158 IF(IMAT.EQ.0)GO TO 326 159C 160C CORE ALLOCATION FOR ARRAYS B, C, AND D FOR N.G.F. SOLUTION 161C 162 NEQ=N1+2*M1 163 NEQ2=N-N1+2*(M-M1)+NSCON+2*NPCON 164 CALL FBNGF(NEQ,NEQ2,IRESRV,IB11,IC11,ID11,IX11) 165 GO TO 6 166326 NEQ=N+2*M 167 NEQ2=0 168 IB11=1 169 IC11=1 170 ID11=1 171 IX11=1 172 ICASX=0 1736 NPEQ=NP+2*MP 174 WRITE(3,135) 175C 176C DEFAULT VALUES FOR INPUT PARAMETERS AND FLAGS 177C 178C*** 179 IPLP1=0 180 IPLP2=0 181 IPLP3=0 182 IPLP4=0 183C*** 184 IGO=1 185 FMHZS=CVEL 186 NFRQ=1 187 RKH=1. 188 IEXK=0 189 IXTYP=0 190 NLOAD=0 191 NONET=0 192 NEAR=-1 193 IPTFLG=-2 194 IPTFLQ=-1 195 IFAR=-1 196 ZRATI=(1.,0.) 197 IPED=0 198 IRNGF=0 199 NCOUP=0 200 ICOUP=0 201 IF(ICASX.GT.0)GO TO 14 202 FMHZ=CVEL 203 NLODF=0 204 KSYMP=1 205 NRADL=0 206 IPERF=0 207C 208C MAIN INPUT SECTION - STANDARD READ STATEMENT - JUMPS TO APPRO- 209C PRIATE SECTION FOR SPECIFIC PARAMETER SET UP 210C 21114 CALL READMN(2,AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,TMP4, 212 &TMP5,TMP6) 213 MPCNT=MPCNT+1 214 WRITE(3,137) MPCNT,AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3, 215 1TMP4,TMP5,TMP6 216 IF (AIN.EQ.ATST(2)) GO TO 16 217 IF (AIN.EQ.ATST(3)) GO TO 17 218 IF (AIN.EQ.ATST(4)) GO TO 21 219 IF (AIN.EQ.ATST(5)) GO TO 24 220 IF (AIN.EQ.ATST(6)) GO TO 28 221 IF (AIN.EQ.ATST(14)) GO TO 28 222 IF (AIN.EQ.ATST(15)) GO TO 31 223 IF (AIN.EQ.ATST(18)) GO TO 319 224 IF (AIN.EQ.ATST(7)) GO TO 37 225 IF (AIN.EQ.ATST(8)) GO TO 32 226 IF (AIN.EQ.ATST(17)) GO TO 208 227 IF (AIN.EQ.ATST(9)) GO TO 34 228 IF (AIN.EQ.ATST(10)) GO TO 36 229 IF (AIN.EQ.ATST(16)) GO TO 305 230 IF (AIN.EQ.ATST(19)) GO TO 320 231 IF (AIN.EQ.ATST(12)) GO TO 1 232 IF (AIN.EQ.ATST(20)) GO TO 322 233 IF (AIN.EQ.ATST(21)) GO TO 304 234C*** 235 IF (AIN.EQ.ATST(22)) GO TO 330 236C*** 237 IF (AIN.NE.ATST(13)) GO TO 15 238 CALL SECONDS(TMP1) 239 TMP1=TMP1-EXTIM 240 WRITE(3,201) TMP1 241 STOP 24215 WRITE(3,138) 243 STOP 244C 245C FREQUENCY PARAMETERS 246C 24716 IFRQ=ITMP1 248 IF(ICASX.EQ.0)GO TO 8 249 WRITE(3,303) AIN 250 STOP 2518 NFRQ=ITMP2 252 IF (NFRQ.EQ.0) NFRQ=1 253 FMHZ=TMP1 254 DELFRQ=TMP2 255 IF(IPED.EQ.1)ZPNORM=0. 256 IGO=1 257 IFLOW=1 258 GO TO 14 259C 260C MATRIX INTEGRATION LIMIT 261C 262305 RKH=TMP1 263 IF(IGO.GT.2)IGO=2 264 IFLOW=1 265 GO TO 14 266C 267C EXTENDED THIN WIRE KERNEL OPTION 268C 269320 IEXK=1 270 IF(ITMP1.EQ.-1)IEXK=0 271 IF(IGO.GT.2)IGO=2 272 IFLOW=1 273 GO TO 14 274C 275C MAXIMUM COUPLING BETWEEN ANTENNAS 276C 277304 IF(IFLOW.NE.2)NCOUP=0 278 ICOUP=0 279 IFLOW=2 280 IF(ITMP2.EQ.0)GO TO 14 281 NCOUP=NCOUP+1 282 IF(NCOUP.GT.5)GO TO 312 283 NCTAG(NCOUP)=ITMP1 284 NCSEG(NCOUP)=ITMP2 285 IF(ITMP4.EQ.0)GO TO 14 286 NCOUP=NCOUP+1 287 IF(NCOUP.GT.5)GO TO 312 288 NCTAG(NCOUP)=ITMP3 289 NCSEG(NCOUP)=ITMP4 290 GO TO 14 291312 WRITE(3,313) 292 STOP 293C 294C LOADING PARAMETERS 295C 29617 IF (IFLOW.EQ.3) GO TO 18 297 NLOAD=0 298 IFLOW=3 299 IF (IGO.GT.2) IGO=2 300 IF (ITMP1.EQ.(-1)) GO TO 14 30118 NLOAD=NLOAD+1 302 IF (NLOAD.LE.LOADMX) GO TO 19 303 WRITE(3,139) 304 STOP 30519 LDTYP(NLOAD)=ITMP1 306 LDTAG(NLOAD)=ITMP2 307 IF (ITMP4.EQ.0) ITMP4=ITMP3 308 LDTAGF(NLOAD)=ITMP3 309 LDTAGT(NLOAD)=ITMP4 310 IF (ITMP4.GE.ITMP3) GO TO 20 311 WRITE(3,140) NLOAD,ITMP3,ITMP4 312 STOP 31320 ZLR(NLOAD)=TMP1 314 ZLI(NLOAD)=TMP2 315 ZLC(NLOAD)=TMP3 316 GO TO 14 317C 318C GROUND PARAMETERS UNDER THE ANTENNA 319C 32021 IFLOW=4 321 IF(ICASX.EQ.0)GO TO 10 322 WRITE(3,303) AIN 323 STOP 32410 IF (IGO.GT.2) IGO=2 325 IF (ITMP1.NE.(-1)) GO TO 22 326 KSYMP=1 327 NRADL=0 328 IPERF=0 329 GO TO 14 33022 IPERF=ITMP1 331 NRADL=ITMP2 332 KSYMP=2 333 EPSR=TMP1 334 SIG=TMP2 335 IF (NRADL.EQ.0) GO TO 23 336 IF(IPERF.NE.2)GO TO 314 337 WRITE(3,390) 338 STOP 339314 SCRWLT=TMP3 340 SCRWRT=TMP4 341 GO TO 14 34223 EPSR2=TMP3 343 SIG2=TMP4 344 CLT=TMP5 345 CHT=TMP6 346 GO TO 14 347C 348C EXCITATION PARAMETERS 349C 35024 IF (IFLOW.EQ.5) GO TO 25 351 NSANT=0 352 NVQD=0 353 IPED=0 354 IFLOW=5 355 IF (IGO.GT.3) IGO=3 35625 MASYM=ITMP4/10 357 IF (ITMP1.GT.0.AND.ITMP1.NE.5) GO TO 27 358 IXTYP=ITMP1 359 NTSOL=0 360 IF(IXTYP.EQ.0)GO TO 205 361 NVQD=NVQD+1 362 IF(NVQD.GT.NSMAX)GO TO 206 363 IVQD(NVQD)=ISEGNO(ITMP2,ITMP3) 364 VQD(NVQD)=DCMPLX(TMP1,TMP2) 365 IF(ABS(VQD(NVQD)).LT.1.D-20)VQD(NVQD)=(1.,0.) 366 GO TO 207 367205 NSANT=NSANT+1 368 IF (NSANT.LE.NSMAX) GO TO 26 369206 WRITE(3,141) 370 STOP 37126 ISANT(NSANT)=ISEGNO(ITMP2,ITMP3) 372 VSANT(NSANT)=DCMPLX(TMP1,TMP2) 373 IF (ABS(VSANT(NSANT)).LT.1.D-20) VSANT(NSANT)=(1.,0.) 374207 IPED=ITMP4-MASYM*10 375 ZPNORM=TMP3 376 IF (IPED.EQ.1.AND.ZPNORM.GT.0) IPED=2 377 GO TO 14 37827 IF (IXTYP.EQ.0.OR.IXTYP.EQ.5) NTSOL=0 379 IXTYP=ITMP1 380 NTHI=ITMP2 381 NPHI=ITMP3 382 XPR1=TMP1 383 XPR2=TMP2 384 XPR3=TMP3 385 XPR4=TMP4 386 XPR5=TMP5 387 XPR6=TMP6 388 NSANT=0 389 NVQD=0 390 THETIS=XPR1 391 PHISS=XPR2 392 GO TO 14 393C 394C NETWORK PARAMETERS 395C 39628 IF (IFLOW.EQ.6) GO TO 29 397 NONET=0 398 NTSOL=0 399 IFLOW=6 400 IF (IGO.GT.3) IGO=3 401 IF (ITMP2.EQ.(-1)) GO TO 14 40229 NONET=NONET+1 403 IF (NONET.LE.NETMX) GO TO 30 404 WRITE(3,142) 405 STOP 40630 NTYP(NONET)=2 407 IF (AIN.EQ.ATST(6)) NTYP(NONET)=1 408 ISEG1(NONET)=ISEGNO(ITMP1,ITMP2) 409 ISEG2(NONET)=ISEGNO(ITMP3,ITMP4) 410 X11R(NONET)=TMP1 411 X11I(NONET)=TMP2 412 X12R(NONET)=TMP3 413 X12I(NONET)=TMP4 414 X22R(NONET)=TMP5 415 X22I(NONET)=TMP6 416 IF (NTYP(NONET).EQ.1.OR.TMP1.GT.0.) GO TO 14 417 NTYP(NONET)=3 418 X11R(NONET)=-TMP1 419 GO TO 14 420C*** 421C 422C PLOT FLAGS 423C 424330 IPLP1=ITMP1 425 IPLP2=ITMP2 426 IPLP3=ITMP3 427 IPLP4=ITMP4 428 OPEN (UNIT=8,FILE='PLTDAT.NEC',STATUS='NEW',ERR=14) 429C*** 430 GO TO 14 431C 432C PRINT CONTROL FOR CURRENT 433C 43431 IPTFLG=ITMP1 435 IPTAG=ITMP2 436 IPTAGF=ITMP3 437 IPTAGT=ITMP4 438 IF(ITMP3.EQ.0.AND.IPTFLG.NE.-1)IPTFLG=-2 439 IF (ITMP4.EQ.0) IPTAGT=IPTAGF 440 GO TO 14 441C 442C WRITE CONTROL FOR CHARGE 443C 444319 IPTFLQ=ITMP1 445 IPTAQ=ITMP2 446 IPTAQF=ITMP3 447 IPTAQT=ITMP4 448 IF(ITMP3.EQ.0.AND.IPTFLQ.NE.-1)IPTFLQ=-2 449 IF(ITMP4.EQ.0)IPTAQT=IPTAQF 450 GO TO 14 451C 452C NEAR FIELD CALCULATION PARAMETERS 453C 454208 NFEH=1 455 GO TO 209 45632 NFEH=0 457209 IF (.NOT.(IFLOW.EQ.8.AND.NFRQ.NE.1)) GO TO 33 458 WRITE(3,143) 45933 NEAR=ITMP1 460 NRX=ITMP2 461 NRY=ITMP3 462 NRZ=ITMP4 463 XNR=TMP1 464 YNR=TMP2 465 ZNR=TMP3 466 DXNR=TMP4 467 DYNR=TMP5 468 DZNR=TMP6 469 IFLOW=8 470 IF (NFRQ.NE.1) GO TO 14 471 GO TO (41,46,53,71,72), IGO 472C 473C GROUND REPRESENTATION 474C 47534 EPSR2=TMP1 476 SIG2=TMP2 477 CLT=TMP3 478 CHT=TMP4 479 IFLOW=9 480 GO TO 14 481C 482C STANDARD OBSERVATION ANGLE PARAMETERS 483C 48436 IFAR=ITMP1 485 NTH=ITMP2 486 NPH=ITMP3 487 IF (NTH.EQ.0) NTH=1 488 IF (NPH.EQ.0) NPH=1 489 IPD=ITMP4/10 490 IAVP=ITMP4-IPD*10 491 INOR=IPD/10 492 IPD=IPD-INOR*10 493 IAX=INOR/10 494 INOR=INOR-IAX*10 495 IF (IAX.NE.0) IAX=1 496 IF (IPD.NE.0) IPD=1 497 IF (NTH.LT.2.OR.NPH.LT.2) IAVP=0 498 IF (IFAR.EQ.1) IAVP=0 499 THETS=TMP1 500 PHIS=TMP2 501 DTH=TMP3 502 DPH=TMP4 503 RFLD=TMP5 504 GNOR=TMP6 505 IFLOW=10 506 GO TO (41,46,53,71,78), IGO 507C 508C WRITE NUMERICAL GREEN'S FUNCTION TAPE 509C 510322 IFLOW=12 511 IF(ICASX.EQ.0)GO TO 301 512 WRITE(3,302) 513 STOP 514301 IRNGF=IRESRV/2 515 GO TO (41,46,52,52,52),IGO 516C 517C EXECUTE CARD - CALC. INCLUDING RADIATED FIELDS 518C 51937 IF (IFLOW.EQ.10.AND.ITMP1.EQ.0) GO TO 14 520 IF (NFRQ.EQ.1.AND.ITMP1.EQ.0.AND.IFLOW.GT.7) GO TO 14 521 IF (ITMP1.NE.0) GO TO 39 522 IF (IFLOW.GT.7) GO TO 38 523 IFLOW=7 524 GO TO 40 52538 IFLOW=11 526 GO TO 40 52739 IFAR=0 528 RFLD=0. 529 IPD=0 530 IAVP=0 531 INOR=0 532 IAX=0 533 NTH=91 534 NPH=1 535 THETS=0. 536 PHIS=0. 537 DTH=1.0 538 DPH=0. 539 IF (ITMP1.EQ.2) PHIS=90. 540 IF (ITMP1.NE.3) GO TO 40 541 NPH=2 542 DPH=90. 54340 GO TO (41,46,53,71,78), IGO 544C 545C END OF THE MAIN INPUT SECTION 546C 547C BEGINNING OF THE FREQUENCY DO LOOP 548C 54941 MHZ=1 550C*** 551 IF(N.EQ.0 .OR. IFRTIMW .EQ. 1)GO TO 406 552 IFRTIMW=1 553 DO 445 I=1,N 554 XTEMP(I)=X(I) 555 YTEMP(I)=Y(I) 556 ZTEMP(I)=Z(I) 557 SITEMP(I)=SI(I) 558 BITEMP(I)=BI(I) 559445 CONTINUE 560406 IF(M.EQ.0 .OR. IFRTIMP .EQ. 1)GO TO 407 561 IFRTIMP=1 562 J=LD+1 563 DO 545 I=1,M 564 J=J-1 565 XTEMP(J)=X(J) 566 YTEMP(J)=Y(J) 567 ZTEMP(J)=Z(J) 568 BITEMP(J)=BI(J) 569545 CONTINUE 570407 CONTINUE 571 FMHZ1=FMHZ 572C*** 573C CORE ALLOCATION FOR PRIMARY INTERACTON MATRIX. (A) 574 IF(IMAT.EQ.0)CALL FBLOCK(NPEQ,NEQ,IRESRV,IRNGF,IPSYM) 57542 IF (MHZ.EQ.1) GO TO 44 576 IF (IFRQ.EQ.1) GO TO 43 577C FMHZ=FMHZ+DELFRQ 578C*** 579 FMHZ=FMHZ1+(MHZ-1)*DELFRQ 580 GO TO 44 58143 FMHZ=FMHZ*DELFRQ 58244 FR=FMHZ/CVEL 583C*** 584 WLAM=CVEL/FMHZ 585 WRITE(3,145) FMHZ,WLAM 586 WRITE(3,196) RKH 587 IF(IEXK.EQ.1)WRITE(3,321) 588C FREQUENCY SCALING OF GEOMETRIC PARAMETERS 589C*** FMHZS=FMHZ 590 IF(N.EQ.0)GO TO 306 591 DO 45 I=1,N 592C*** 593 X(I)=XTEMP(I)*FR 594 Y(I)=YTEMP(I)*FR 595 Z(I)=ZTEMP(I)*FR 596 SI(I)=SITEMP(I)*FR 59745 BI(I)=BITEMP(I)*FR 598C*** 599306 IF(M.EQ.0)GO TO 307 600 FR2=FR*FR 601 J=LD+1 602 DO 245 I=1,M 603 J=J-1 604C*** 605 X(J)=XTEMP(J)*FR 606 Y(J)=YTEMP(J)*FR 607 Z(J)=ZTEMP(J)*FR 608245 BI(J)=BITEMP(J)*FR2 609C*** 610307 IGO=2 611C STRUCTURE SEGMENT LOADING 61246 WRITE(3,146) 613 IF(NLOAD.NE.0) CALL LOAD(LDTYP,LDTAG,LDTAGF,LDTAGT,ZLR,ZLI,ZLC) 614 IF(NLOAD.EQ.0.AND.NLODF.EQ.0)WRITE(3,147) 615 IF(NLOAD.EQ.0.AND.NLODF.NE.0)WRITE(3,327) 616C GROUND PARAMETER 617 WRITE(3,148) 618 IF (KSYMP.EQ.1) GO TO 49 619 FRATI=(1.,0.) 620 IF (IPERF.EQ.1) GO TO 48 621 IF(SIG.LT.0.)SIG=-SIG/(59.96*WLAM) 622 EPSC=DCMPLX(EPSR,-SIG*WLAM*59.96) 623 ZRATI=1./SQRT(EPSC) 624 U=ZRATI 625 U2=U*U 626 IF (NRADL.EQ.0) GO TO 47 627 SCRWL=SCRWLT/WLAM 628 SCRWR=SCRWRT/WLAM 629 T1=FJ*2367.067D+0/DFLOAT(NRADL) 630 T2=SCRWR*DFLOAT(NRADL) 631 WRITE(3,170) NRADL,SCRWLT,SCRWRT 632 WRITE(3,149) 63347 IF(IPERF.EQ.2)GO TO 328 634 WRITE(3,391) 635 GO TO 329 636328 CALL SOMNEC(EPSR, SIG, FMHZ) 637 FRATI=(EPSC-1.)/(EPSC+1.) 638 IF(ABS((EPSCF-EPSC)/EPSC).LT.1.D-3)GO TO 400 639 WRITE(3,393) EPSCF,EPSC 640 STOP 641400 WRITE(3,392) 642329 WRITE(3,150) EPSR,SIG,EPSC 643 GO TO 50 64448 WRITE(3,151) 645 GO TO 50 64649 WRITE(3,152) 64750 CONTINUE 648C * * * 649C FILL AND FACTOR PRIMARY INTERACTION MATRIX 650C 651 CALL SECONDS (TIM1) 652 IF(ICASX.NE.0)GO TO 324 653 CALL CMSET(NEQ,CM,RKH,IEXK) 654 CALL SECONDS (TIM2) 655 TIM=TIM2-TIM1 656 CALL FACTRS(NPEQ,NEQ,CM,IP,IX,11,12,13,14) 657 GO TO 323 658C 659C N.G.F. - FILL B, C, AND D AND FACTOR D-C(INV(A)B) 660C 661C **** 662324 IF(NEQ2.EQ.0)GO TO 333 663C **** 664 CALL CMNGF(CM(IB11),CM(IC11),CM(ID11),NPBX,NEQ,NEQ2,RKH,IEXK) 665 CALL SECONDS (TIM2) 666 TIM=TIM2-TIM1 667 CALL FACGF(CM,CM(IB11),CM(IC11),CM(ID11),CM(IX11),IP,IX,NP,N1,MP, 668 1M1,NEQ,NEQ2) 669323 CALL SECONDS (TIM1) 670 TIM2=TIM1-TIM2 671 WRITE(3,153) TIM,TIM2 672333 IGO=3 673 NTSOL=0 674 IF(IFLOW.NE.12)GO TO 53 675C WRITE N.G.F. FILE 67652 CALL GFOUT 677 GO TO 14 678C 679C EXCITATION SET UP (RIGHT HAND SIDE, -E INC.) 680C 68153 NTHIC=1 682 NPHIC=1 683 INC=1 684 NPRINT=0 68554 IF (IXTYP.EQ.0.OR.IXTYP.EQ.5) GO TO 56 686 IF (IPTFLG.LE.0.OR.IXTYP.EQ.4) WRITE(3,154) 687 TMP5=TA*XPR5 688 TMP4=TA*XPR4 689 IF (IXTYP.NE.4) GO TO 55 690 TMP1=XPR1/WLAM 691 TMP2=XPR2/WLAM 692 TMP3=XPR3/WLAM 693 TMP6=XPR6/(WLAM*WLAM) 694 WRITE(3,156) XPR1,XPR2,XPR3,XPR4,XPR5,XPR6 695 GO TO 56 69655 TMP1=TA*XPR1 697 TMP2=TA*XPR2 698 TMP3=TA*XPR3 699 TMP6=XPR6 700 IF (IPTFLG.LE.0) WRITE(3,155) XPR1,XPR2,XPR3,HPOL(IXTYP),XPR6 70156 CALL ETMNS (TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,IXTYP,CUR) 702C 703C MATRIX SOLVING (NETWK CALLS SOLVES) 704C 705 IF (NONET.EQ.0.OR.INC.GT.1) GO TO 60 706 WRITE(3,158) 707 ITMP3=0 708 ITMP1=NTYP(1) 709 DO 59 I=1,2 710 IF (ITMP1.EQ.3) ITMP1=2 711 IF (ITMP1.EQ.2) WRITE(3,159) 712 IF (ITMP1.EQ.1) WRITE(3,160) 713 DO 58 J=1,NONET 714 ITMP2=NTYP(J) 715 IF ((ITMP2/ITMP1).EQ.1) GO TO 57 716 ITMP3=ITMP2 717 GO TO 58 71857 ITMP4=ISEG1(J) 719 ITMP5=ISEG2(J) 720 IF (ITMP2.GE.2.AND.X11I(J).LE.0.) X11I(J)=WLAM*SQRT((X(ITMP5)- 721 1 X(ITMP4))**2+(Y(ITMP5)-Y(ITMP4))**2+(Z(ITMP5)-Z(ITMP4))**2) 722 WRITE(3,157) ITAG(ITMP4),ITMP4,ITAG(ITMP5),ITMP5,X11R(J),X11 723 1I(J),X12R(J),X12I(J),X22R(J),X22I(J),PNET(2*ITMP2-1),PNET(2*ITMP2) 72458 CONTINUE 725 IF (ITMP3.EQ.0) GO TO 60 726 ITMP1=ITMP3 72759 CONTINUE 72860 CONTINUE 729 IF (INC.GT.1.AND.IPTFLG.GT.0) NPRINT=1 730 CALL NETWK(CM,CM(IB11),CM(IC11),CM(ID11),IP,CUR) 731 NTSOL=1 732 IF (IPED.EQ.0) GO TO 61 733 ITMP1=MHZ+4*(MHZ-1) 734 IF (ITMP1.GT.(NORMF-3)) GO TO 61 735 FNORM(ITMP1)=DREAL(ZPED) 736 FNORM(ITMP1+1)=DIMAG(ZPED) 737 FNORM(ITMP1+2)=ABS(ZPED) 738 FNORM(ITMP1+3)=CANG(ZPED) 739 IF (IPED.EQ.2) GO TO 61 740 IF (FNORM(ITMP1+2).GT.ZPNORM) ZPNORM=FNORM(ITMP1+2) 74161 CONTINUE 742C 743C PRINTING STRUCTURE CURRENTS 744C 745 IF(N.EQ.0)GO TO 308 746 IF (IPTFLG.EQ.(-1)) GO TO 63 747 IF (IPTFLG.GT.0) GO TO 62 748 WRITE(3,161) 749 WRITE(3,162) 750 GO TO 63 75162 IF (IPTFLG.EQ.3.OR.INC.GT.1) GO TO 63 752 WRITE(3,163) XPR3,HPOL(IXTYP),XPR6 75363 PLOSS=0. 754 ITMP1=0 755 JUMP=IPTFLG+1 756 DO 69 I=1,N 757 CURI=CUR(I)*WLAM 758 CMAG=ABS(CURI) 759 PH=CANG(CURI) 760 IF (NLOAD.EQ.0.AND.NLODF.EQ.0) GO TO 64 761 IF (ABS(DREAL(ZARRAY(I))).LT.1.D-20) GO TO 64 762 PLOSS=PLOSS+.5*CMAG*CMAG*DREAL(ZARRAY(I))*SI(I) 76364 IF (JUMP) 68,69,65 76465 IF (IPTAG.EQ.0) GO TO 66 765 IF (ITAG(I).NE.IPTAG) GO TO 69 76666 ITMP1=ITMP1+1 767 IF (ITMP1.LT.IPTAGF.OR.ITMP1.GT.IPTAGT) GO TO 69 768 IF (IPTFLG.EQ.0) GO TO 68 769 IF (IPTFLG.LT.2.OR.INC.GT.NORMF) GO TO 67 770 FNORM(INC)=CMAG 771 ISAVE=I 77267 IF (IPTFLG.NE.3) WRITE(3,164) XPR1,XPR2,CMAG,PH,I 773 GO TO 69 77468 WRITE(3,165) I,ITAG(I),X(I),Y(I),Z(I),SI(I),CURI,CMAG,PH 775C*** 776 IF(IPLP1 .NE. 1) GO TO 69 777 IF(IPLP2 .EQ. 1) WRITE(8,*) CURI 778 IF(IPLP2 .EQ. 2) WRITE(8,*) CMAG,PH 779C*** 78069 CONTINUE 781 IF(IPTFLQ.EQ.(-1))GO TO 308 782 WRITE(3,315) 783 ITMP1=0 784 FR=1.D-6/FMHZ 785 DO 316 I=1,N 786 IF(IPTFLQ.EQ.(-2))GO TO 318 787 IF(IPTAQ.EQ.0)GO TO 317 788 IF(ITAG(I).NE.IPTAQ)GO TO 316 789317 ITMP1=ITMP1+1 790 IF(ITMP1.LT.IPTAQF.OR.ITMP1.GT.IPTAQT)GO TO 316 791318 CURI=FR*DCMPLX(-BII(I),BIR(I)) 792 CMAG=ABS(CURI) 793 PH=CANG(CURI) 794 WRITE(3,165) I,ITAG(I),X(I),Y(I),Z(I),SI(I),CURI,CMAG,PH 795316 CONTINUE 796308 IF(M.EQ.0)GO TO 310 797 WRITE(3,197) 798 J=N-2 799 ITMP1=LD+1 800 DO 309 I=1,M 801 J=J+3 802 ITMP1=ITMP1-1 803 EX=CUR(J) 804 EY=CUR(J+1) 805 EZ=CUR(J+2) 806 ETH=EX*T1X(ITMP1)+EY*T1Y(ITMP1)+EZ*T1Z(ITMP1) 807 EPH=EX*T2X(ITMP1)+EY*T2Y(ITMP1)+EZ*T2Z(ITMP1) 808 ETHM=ABS(ETH) 809 ETHA=CANG(ETH) 810 EPHM=ABS(EPH) 811 EPHA=CANG(EPH) 812C309 WRITE(3,198) I,X(ITMP1),Y(ITMP1),Z(ITMP1),ETHM,ETHA,EPHM,EPHA,E 813C 1X,EY, EZ 814C*** 815 WRITE(3,198) I,X(ITMP1),Y(ITMP1),Z(ITMP1),ETHM,ETHA,EPHM,EPHA,E 816 1X,EY,EZ 817 IF(IPLP1 .NE. 1) GO TO 309 818 IF(IPLP3 .EQ. 1) WRITE(8,*) EX 819 IF(IPLP3 .EQ. 2) WRITE(8,*) EY 820 IF(IPLP3 .EQ. 3) WRITE(8,*) EZ 821 IF(IPLP3 .EQ. 4) WRITE(8,*) EX,EY,EZ 822309 CONTINUE 823C*** 824310 IF (IXTYP.NE.0.AND.IXTYP.NE.5) GO TO 70 825 TMP1=PIN-PNLS-PLOSS 826 TMP2=100.*TMP1/PIN 827 WRITE(3,166) PIN,TMP1,PLOSS,PNLS,TMP2 82870 CONTINUE 829 IGO=4 830 IF(NCOUP.GT.0)CALL COUPLE(CUR,WLAM) 831 IF (IFLOW.NE.7) GO TO 71 832 IF (IXTYP.GT.0.AND.IXTYP.LT.4) GO TO 113 833 IF (NFRQ.NE.1) GO TO 120 834 WRITE(3,135) 835 GO TO 14 83671 IGO=5 837C 838C NEAR FIELD CALCULATION 839C 84072 IF (NEAR.EQ.(-1)) GO TO 78 841 CALL NFPAT 842 IF (MHZ.EQ.NFRQ) NEAR=-1 843 IF (NFRQ.NE.1) GO TO 78 844 WRITE(3,135) 845 GO TO 14 846C 847C STANDARD FAR FIELD CALCULATION 848C 84978 IF(IFAR.EQ.-1)GO TO 113 850 PINR=PIN 851 PNLR=PNLS 852 CALL RDPAT 853113 IF (IXTYP.EQ.0.OR.IXTYP.GE.4) GO TO 119 854 NTHIC=NTHIC+1 855 INC=INC+1 856 XPR1=XPR1+XPR4 857 IF (NTHIC.LE.NTHI) GO TO 54 858 NTHIC=1 859 XPR1=THETIS 860 XPR2=XPR2+XPR5 861 NPHIC=NPHIC+1 862 IF (NPHIC.LE.NPHI) GO TO 54 863 NPHIC=1 864 XPR2=PHISS 865 IF (IPTFLG.LT.2) GO TO 119 866C NORMALIZED RECEIVING PATTERN PRINTED 867 ITMP1=NTHI*NPHI 868 IF (ITMP1.LE.NORMF) GO TO 114 869 ITMP1=NORMF 870 WRITE(3,181) 871114 TMP1=FNORM(1) 872 DO 115 J=2,ITMP1 873 IF (FNORM(J).GT.TMP1) TMP1=FNORM(J) 874115 CONTINUE 875 WRITE(3,182) TMP1,XPR3,HPOL(IXTYP),XPR6,ISAVE 876 DO 118 J=1,NPHI 877 ITMP2=NTHI*(J-1) 878 DO 116 I=1,NTHI 879 ITMP3=I+ITMP2 880 IF (ITMP3.GT.ITMP1) GO TO 117 881 TMP2=FNORM(ITMP3)/TMP1 882 TMP3=DB20(TMP2) 883 WRITE(3,183) XPR1,XPR2,TMP3,TMP2 884 XPR1=XPR1+XPR4 885116 CONTINUE 886117 XPR1=THETIS 887 XPR2=XPR2+XPR5 888118 CONTINUE 889 XPR2=PHISS 890119 IF (MHZ.EQ.NFRQ) IFAR=-1 891 IF (NFRQ.NE.1) GO TO 120 892 WRITE(3,135) 893 GO TO 14 894120 MHZ=MHZ+1 895 IF (MHZ.LE.NFRQ) GO TO 42 896 IF (IPED.EQ.0) GO TO 123 897 IF(NVQD.LT.1)GO TO 199 898 WRITE(3,184) IVQD(NVQD),ZPNORM 899 GO TO 204 900199 WRITE(3,184) ISANT(NSANT),ZPNORM 901204 ITMP1=NFRQ 902 IF (ITMP1.LE.(NORMF/4)) GO TO 121 903 ITMP1=NORMF/4 904 WRITE(3,185) 905121 IF (IFRQ.EQ.0) TMP1=FMHZ-(NFRQ-1)*DELFRQ 906 IF (IFRQ.EQ.1) TMP1=FMHZ/(DELFRQ**(NFRQ-1)) 907 DO 122 I=1,ITMP1 908 ITMP2=I+4*(I-1) 909 TMP2=FNORM(ITMP2)/ZPNORM 910 TMP3=FNORM(ITMP2+1)/ZPNORM 911 TMP4=FNORM(ITMP2+2)/ZPNORM 912 TMP5=FNORM(ITMP2+3) 913 WRITE(3,186) TMP1,FNORM(ITMP2),FNORM(ITMP2+1),FNORM(ITMP2+2), 914 1FNORM(ITMP2+3),TMP2,TMP3,TMP4,TMP5 915 IF (IFRQ.EQ.0) TMP1=TMP1+DELFRQ 916 IF (IFRQ.EQ.1) TMP1=TMP1*DELFRQ 917122 CONTINUE 918 WRITE(3,135) 919123 CONTINUE 920 NFRQ=1 921 MHZ=1 922 GO TO 14 923125 FORMAT (A2,19A4) 924126 FORMAT ('1') 925127 FORMAT (///,33X,'*********************************************', 926 &//,36X,'NUMERICAL ELECTROMAGNETICS CODE (NEC-2D)',//,33X, 927 2 '*********************************************') 928128 FORMAT (////,37X,'- - - - COMMENTS - - - -',//) 929129 FORMAT (25X,20A4) 930130 FORMAT (///,10X,'INCORRECT LABEL FOR A COMMENT CARD') 931135 FORMAT (/////) 932136 FORMAT (A2,I3,3I5,6E10.3) 933137 FORMAT (1X,'***** DATA CARD NO.',I3,3X,A2,1X,I3,3(1X,I5), 934 1 6(1X,1P,E12.5)) 935138 FORMAT (///,10X,'FAULTY DATA CARD LABEL AFTER GEOMETRY SECTION') 936139 FORMAT (///,10X,'NUMBER OF LOADING CARDS EXCEEDS STORAGE ALLOTTED' 937 1) 938140 FORMAT (///,10X,'DATA FAULT ON LOADING CARD NO.=',I5,5X, 939 &'ITAG STEP1=',I5,' IS GREATER THAN ITAG STEP2=',I5) 940141 FORMAT (///,10X,'NUMBER OF EXCITATION CARDS EXCEEDS STORAGE ALLO', 941 &'TTED') 942142 FORMAT (///,10X,'NUMBER OF NETWORK CARDS EXCEEDS STORAGE ALLOTTE', 943 &'D') 944143 FORMAT(///,10X,'WHEN MULTIPLE FREQUENCIES ARE REQUESTED, ONLY ON', 945 &'E NEAR FIELD CARD CAN BE USED -',/,10X,'LAST CARD READ IS USED') 946145 FORMAT (////,33X,'- - - - - - FREQUENCY - - - - - -',//,36X, 947 &'FREQUENCY=',1P,E11.4,' MHZ',/,36X,'WAVELENGTH=',E11.4,' METERS') 948146 FORMAT (///,30X,' - - - STRUCTURE IMPEDANCE LOADING - - -') 949147 FORMAT (/ ,35X,'THIS STRUCTURE IS NOT LOADED') 950148 FORMAT (///,34X,'- - - ANTENNA ENVIRONMENT - - -',/) 951149 FORMAT (40X,'MEDIUM UNDER SCREEN -') 952150 FORMAT (40X,'RELATIVE DIELECTRIC CONST.=',F7.3,/,40X,'CONDUCTIV', 953 &'ITY=',1P,E10.3,' MHOS/METER',/,40X,'COMPLEX DIELECTRIC CONSTANT=' 954 &,2E12.5) 955151 FORMAT ( 42X,'PERFECT GROUND') 956152 FORMAT ( 44X,'FREE SPACE') 957153 FORMAT (///,32X,'- - - MATRIX TIMING - - -',//,24X,'FILL=',F9.3, 958 1' SEC., FACTOR=',F9.3,' SEC.') 959154 FORMAT (///,40X,'- - - EXCITATION - - -') 960155 FORMAT (/,4X,'PLANE WAVE',4X,'THETA=',F7.2,' DEG, PHI=',F7.2, 961 &' DEG, ETA=',F7.2,' DEG, TYPE -',A6,'= AXIAL RATIO=',F6.3) 962156 FORMAT (/,31X,'POSITION (METERS)',14X,'ORIENTATION (DEG)=',/,28X, 963 1'X',12X,'Y',12X,'Z',10X,'ALPHA',5X,'BETA',4X,'DIPOLE MOMENT',// 964 2 ,4X,'CURRENT SOURCE',1X,3(3X,F10.5),1X,2(3X,F7.2),4X,F8.3) 965157 FORMAT (4X,4(I5,1X),1P,6(3X,E11.4),3X,A6,A2) 966158 FORMAT (///,44X,'- - - NETWORK DATA - - -') 967159 FORMAT (/,6X,'- FROM - - TO -',11X,'TRANSMISSION LINE',15X, 968 &'- - SHUNT ADMITTANCES (MHOS) - -',14X,'LINE',/,6X,'TAG SEG.' 969 2,' TAG SEG.',6X,'IMPEDANCE',6X,'LENGTH',12X,'- END ONE -',17X, 970 3'- END TWO -',12X,'TYPE',/,6X,'NO. NO. NO. NO.',9X,'OHMS', 971 &8X,'METERS',9X,'REAL',10X,'IMAG.',9X,'REAL',10X,'IMAG.') 972160 FORMAT (/,6X,'- FROM -',4X,'- TO -',26X,'- - ADMITTANCE MATRIX', 973 1' ELEMENTS (MHOS) - -',/,6X,'TAG SEG. TAG SEG.',13X,'(ON', 974 2'E,ONE)',19X,'(ONE,TWO)',19X,'(TWO,TWO)',/ ,6X,'NO. NO. NO', 975 3'. NO.',8X,'REAL',10X,'IMAG.',9X,'REAL',10X,'IMAG.',9X,'REAL', 976 4 10X,'IMAG.') 977161 FORMAT (///,29X,'- - - CURRENTS AND LOCATION - - -',//,33X, 978 &'DISTANCES IN WAVELENGTHS') 979162 FORMAT ( //,2X,'SEG.',2X,'TAG',4X,'COORD. OF SEG. CENTER',5X, 980 1 'SEG.',12X,'- - - CURRENT (AMPS) - - -',/,2X,'NO.',3X,'NO.', 981 2 5X,'X',8X,'Y',8X,'Z',6X,'LENGTH',5X,'REAL',8X,'IMAG.',7X,'MAG.', 982 3 8X,'PHASE') 983163 FORMAT (///,33X,'- - - RECEIVING PATTERN PARAMETERS - - -',/,43X, 984 &'ETA=',F7.2,' DEGREES',/,43X,'TYPE -',A6,/,43X,'AXIAL RATIO=', 985 & F6.3,//,11X,'THETA',6X,'PHI',10X,'- CURRENT -',9X,'SEG',/, 986 &11X,'(DEG)',5X,'(DEG)',7X,'MAGNITUDE',4X,'PHASE',6X,'NO.',/) 987164 FORMAT (10X,2(F7.2,3X),1X,1P,E11.4,3X,0P,F7.2,4X,I5) 988165 FORMAT (1X,2I5,3F9.4,F9.5,1X,1P,3E12.4,0P,F9.3) 989166 FORMAT (///,40X,'- - - POWER BUDGET - - -',//,43X,'INPUT POWER = 990 &',1P,E11.4,' WATTS',/ ,43X,'RADIATED POWER=',E11.4,' WATTS', 991 &/,43X,'STRUCTURE LOSS=',E11.4,' WATTS',/,43X,'NETWORK LOSS =', 992 &E11.4,' WATTS',/,43X,'EFFICIENCY =',0P,F7.2,' PERCENT') 993170 FORMAT (40X,'RADIAL WIRE GROUND SCREEN',/,40X,I5,' WIRES',/,40X, 994 1'WIRE LENGTH=',F8.2,' METERS',/,40X,'WIRE RADIUS=',1P,E10.3, 995 2' METERS') 996181 FORMAT (///,4X,'RECEIVING PATTERN STORAGE TOO SMALL,ARRAY TRUNCA', 997 1'TED') 998182 FORMAT (///,32X,'- - - NORMALIZED RECEIVING PATTERN - - -',/,41X, 999 1'NORMALIZATION FACTOR=',1P,E11.4,/,41X,'ETA=',0P,F7.2,' DEGREES', 1000 2/,41X,'TYPE -',A6,/,41X,'AXIAL RATIO=',F6.3,/,41X,'SEGMENT NO.=', 1001 3I5,//,21X,'THETA',6X,'PHI',9X,'- PATTERN -',/,21X,'(DEG)',5X, 1002 4'(DEG)',8X,'DB',8X,'MAGNITUDE',/) 1003183 FORMAT (20X,2(F7.2,3X),1X,F7.2,4X,1P,E11.4) 1004184 FORMAT (///,36X,32H- - - INPUT IMPEDANCE DATA - - -,/ ,45X,18HSO 1005 1URCE SEGMENT NO.,I4,/ ,45X,21HNORMALIZATION FACTOR=,1P,E12.5,// 1006 2,7X,5HFREQ.,13X,34H- - UNNORMALIZED IMPEDANCE - -,21X, 32H- 1007 3 - NORMALIZED IMPEDANCE - -,/ ,19X,10HRESISTANCE,4X,9HREACTA 1008 4NCE,6X,9HMAGNITUDE,4X,5HPHASE,7X,10HRESISTANCE,4X,9HREACTANCE,6X, 1009 5 9HMAGNITUDE,4X,5HPHASE,/ ,8X,3HMHZ,11X,4HOHMS,10X,4HOHMS,11X, 1010 6 4HOHMS,5X,7HDEGREES,47X,7HDEGREES,/) 1011185 FORMAT (///,4X,62HSTORAGE FOR IMPEDANCE NORMALIZATION TOO SMALL, A 1012 1RRAY TRUNCATED) 1013186 FORMAT (3X,F9.3,2X,1P,2(2X,E12.5),3X,E12.5,2X,0P,F7.2,2X,1P,2(2X, 1014 1 E12.5),3X,E12.5,2X,0P,F7.2) 1015196 FORMAT( ////,20X,55HAPPROXIMATE INTEGRATION EMPLOYED FOR SEGMENT 1016 1S MORE THAN,F8.3,18H WAVELENGTHS APART) 1017197 FORMAT( ////,41X,38H- - - - SURFACE PATCH CURRENTS - - - -,//, 1018 1 50X,23HDISTANCE IN WAVELENGTHS,/,50X,21HCURRENT IN AMPS/METER, 1019 1 //,28X,26H- - SURFACE COMPONENTS - -,19X,34H- - - RECTANGULAR COM 1020 1PONENTS - - -,/,6X,12HPATCH CENTER,6X,16HTANGENT VECTOR 1,3X, 1021 116HTANGENT VECTOR 2,11X,1HX,19X,1HY,19X,1HZ,/,5X,1HX,6X,1HY,6X, 1022 11HZ,5X,4HMAG.,7X,5HPHASE,3X,4HMAG.,7X,5HPHASE,3(4X,4HREAL,6X, 1023 1 6HIMAG. )) 1024198 FORMAT(1X,I4,/,1X,3F7.3,2(1P,E11.4,0P,F8.2),1P,6E10.2) 1025201 FORMAT(/,11H RUN TIME =,F10.3) 1026315 FORMAT(///,34X,28H- - - CHARGE DENSITIES - - -,//,36X, 1027 1 24HDISTANCES IN WAVELENGTHS,///,2X,4HSEG.,2X,3HTAG,4X, 1028 2 21HCOORD. OF SEG. CENTER,5X,4HSEG.,10X, 1029 3 31HCHARGE DENSITY (COULOMBS/METER),/,2X,3HNO.,3X,3HNO.,5X,1HX,8X, 1030 4 1HY,8X,1HZ,6X,6HLENGTH,5X,4HREAL,8X,5HIMAG.,7X,4HMAG.,8X,5HPHASE) 1031321 FORMAT( /,20X,42HTHE EXTENDED THIN WIRE KERNEL WILL BE USED) 1032303 FORMAT(/,9H ERROR - ,A2,32H CARD IS NOT ALLOWED WITH N.G.F.) 1033327 FORMAT(/,35X,31H LOADING ONLY IN N.G.F. SECTION) 1034302 FORMAT(48H ERROR - N.G.F. IN USE. CANNOT WRITE NEW N.G.F.) 1035313 FORMAT(/,62H NUMBER OF SEGMENTS IN COUPLING CALCULATION (CP) EXCEE 1036 1DS LIMIT) 1037390 FORMAT(78H RADIAL WIRE G. S. APPROXIMATION MAY NOT BE USED WITH SO 1038 1MMERFELD GROUND OPTION) 1039391 FORMAT(40X,52HFINITE GROUND. REFLECTION COEFFICIENT APPROXIMATION 1040 1) 1041392 FORMAT(40X,35HFINITE GROUND. SOMMERFELD SOLUTION) 1042393 FORMAT(/,29H ERROR IN GROUND PARAMETERS -,/,41H COMPLEX DIELECTRIC 1043 1 CONSTANT FROM FILE IS,1P,2E12.5,/,32X,9HREQUESTED,2E12.5) 1044900 FORMAT(' ERROR OPENING SOMMERFELD GROUND FILE - SOM2D.NEC') 1045 END 1046 SUBROUTINE ARC (ITG,NS,RADA,ANG1,ANG2,RAD) 1047C *** 1048C DOUBLE PRECISION 6/4/85 1049C 1050 PARAMETER (MAXSEG=1500, MAXMAT=1500) 1051 IMPLICIT REAL*8(A-H,O-Z) 1052C *** 1053C 1054C ARC GENERATES SEGMENT GEOMETRY DATA FOR AN ARC OF NS SEGMENTS 1055C 1056 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 1057 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 1058 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 1059 DIMENSION X2(1), Y2(1), Z2(1) 1060 EQUIVALENCE (X2,SI), (Y2,ALP), (Z2,BET) 1061 DATA TA/.01745329252D+0/ 1062 IST=N+1 1063 N=N+NS 1064 NP=N 1065 MP=M 1066 IPSYM=0 1067 IF (NS.LT.1) RETURN 1068 IF (ABS(ANG2-ANG1).LT.360.00001D+0) GO TO 1 1069 WRITE(3,3) 1070 STOP 10711 ANG=ANG1*TA 1072 DANG=(ANG2-ANG1)*TA/NS 1073 XS1=RADA*COS(ANG) 1074 ZS1=RADA*SIN(ANG) 1075 DO 2 I=IST,N 1076 ANG=ANG+DANG 1077 XS2=RADA*COS(ANG) 1078 ZS2=RADA*SIN(ANG) 1079 X(I)=XS1 1080 Y(I)=0. 1081 Z(I)=ZS1 1082 X2(I)=XS2 1083 Y2(I)=0. 1084 Z2(I)=ZS2 1085 XS1=XS2 1086 ZS1=ZS2 1087 BI(I)=RAD 10882 ITAG(I)=ITG 1089 RETURN 1090C 10913 FORMAT (40H ERROR -- ARC ANGLE EXCEEDS 360. DEGREES) 1092 END 1093 FUNCTION ATGN2 (X,Y) 1094C *** 1095C DOUBLE PRECISION 6/4/85 1096C 1097 IMPLICIT REAL*8(A-H,O-Z) 1098C *** 1099C 1100C ATGN2 IS ARCTANGENT FUNCTION MODIFIED TO RETURN 0. WHEN X=Y=0. 1101C 1102 IF (X) 3,1,3 11031 IF (Y) 3,2,3 11042 ATGN2=0. 1105 RETURN 11063 ATGN2=ATAN2(X,Y) 1107 RETURN 1108 END 1109 SUBROUTINE BLCKOT (AR,NUNIT,IX1,IX2,NBLKS,NEOF) 1110C *** 1111C DOUBLE PRECISION 6/4/85 1112C 1113 IMPLICIT REAL*8(A-H,O-Z) 1114C *** 1115C 1116C BLCKOT CONTROLS THE READING AND WRITING OF MATRIX BLOCKS ON FILES 1117C FOR THE OUT-OF-CORE MATRIX SOLUTION. 1118C 1119 COMPLEX*16 AR 1120 DIMENSION AR(1) 1121 I1=(IX1+1)/2 1122 I2=(IX2+1)/2 11231 WRITE (NUNIT) (AR(J),J=I1,I2) 1124 RETURN 1125 ENTRY BLCKIN(AR,NUNIT,IX1,IX2,NBLKS,NEOF) 1126 I1=(IX1+1)/2 1127 I2=(IX2+1)/2 1128 DO 2 I=1,NBLKS 1129 READ (NUNIT,END=3) (AR(J),J=I1,I2) 11302 CONTINUE 1131 RETURN 11323 WRITE(3,4) NUNIT,NBLKS,NEOF 1133 IF (NEOF.NE.777) STOP 1134 NEOF=0 1135 RETURN 1136C 11374 FORMAT (13H EOF ON UNIT,I3,9H NBLKS= ,I3,8H NEOF= ,I5) 1138 END 1139 SUBROUTINE CABC (CURX) 1140C *** 1141C DOUBLE PRECISION 6/4/85 1142C 1143 PARAMETER (MAXSEG=1500, MAXMAT=1500) 1144 IMPLICIT REAL*8(A-H,O-Z) 1145C *** 1146C 1147C CABC COMPUTES COEFFICIENTS OF THE CONSTANT (A), SINE (B), AND 1148C COSINE (C) TERMS IN THE CURRENT INTERPOLATION FUNCTIONS FOR THE 1149C CURRENT VECTOR CUR. 1150C 1151 COMPLEX*16 CUR,CURX,VQDS,CURD,CCJ,VSANT,VQD,CS1,CS2 1152 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 1153 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 1154 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 1155 COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG), 1156 &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG) 1157 COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP 1158 1CON(10),NPCON 1159 COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS( 1160 130),NVQD,NSANT,NQDS 1161 COMMON /ANGL/ SALP(MAXSEG) 1162 DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) 1163 DIMENSION CURX(1), CCJX(2) 1164 EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON 1165 12), (T2Z,ITAG) 1166 EQUIVALENCE (CCJ,CCJX) 1167 DATA TP/6.283185308D+0/,CCJX/0.,-0.01666666667D+0/ 1168 IF (N.EQ.0) GO TO 6 1169 DO 1 I=1,N 1170 AIR(I)=0. 1171 AII(I)=0. 1172 BIR(I)=0. 1173 BII(I)=0. 1174 CIR(I)=0. 11751 CII(I)=0. 1176 DO 2 I=1,N 1177 AR=DREAL(CURX(I)) 1178 AI=DIMAG(CURX(I)) 1179 CALL TBF (I,1) 1180 DO 2 JX=1,JSNO 1181 J=JCO(JX) 1182 AIR(J)=AIR(J)+AX(JX)*AR 1183 AII(J)=AII(J)+AX(JX)*AI 1184 BIR(J)=BIR(J)+BX(JX)*AR 1185 BII(J)=BII(J)+BX(JX)*AI 1186 CIR(J)=CIR(J)+CX(JX)*AR 11872 CII(J)=CII(J)+CX(JX)*AI 1188 IF (NQDS.EQ.0) GO TO 4 1189 DO 3 IS=1,NQDS 1190 I=IQDS(IS) 1191 JX=ICON1(I) 1192 ICON1(I)=0 1193 CALL TBF (I,0) 1194 ICON1(I)=JX 1195 SH=SI(I)*.5 1196 CURD=CCJ*VQDS(IS)/((LOG(2.*SH/BI(I))-1.)*(BX(JSNO)*COS(TP*SH)+CX( 1197 1JSNO)*SIN(TP*SH))*WLAM) 1198 AR=DREAL(CURD) 1199 AI=DIMAG(CURD) 1200 DO 3 JX=1,JSNO 1201 J=JCO(JX) 1202 AIR(J)=AIR(J)+AX(JX)*AR 1203 AII(J)=AII(J)+AX(JX)*AI 1204 BIR(J)=BIR(J)+BX(JX)*AR 1205 BII(J)=BII(J)+BX(JX)*AI 1206 CIR(J)=CIR(J)+CX(JX)*AR 12073 CII(J)=CII(J)+CX(JX)*AI 12084 DO 5 I=1,N 12095 CURX(I)=DCMPLX(AIR(I)+CIR(I),AII(I)+CII(I)) 12106 IF (M.EQ.0) RETURN 1211C CONVERT SURFACE CURRENTS FROM T1,T2 COMPONENTS TO X,Y,Z COMPONENTS 1212 K=LD-M 1213 JCO1=N+2*M+1 1214 JCO2=JCO1+M 1215 DO 7 I=1,M 1216 K=K+1 1217 JCO1=JCO1-2 1218 JCO2=JCO2-3 1219 CS1=CURX(JCO1) 1220 CS2=CURX(JCO1+1) 1221 CURX(JCO2)=CS1*T1X(K)+CS2*T2X(K) 1222 CURX(JCO2+1)=CS1*T1Y(K)+CS2*T2Y(K) 12237 CURX(JCO2+2)=CS1*T1Z(K)+CS2*T2Z(K) 1224 RETURN 1225 END 1226 FUNCTION CANG (Z) 1227C *** 1228C DOUBLE PRECISION 6/4/85 1229C 1230 IMPLICIT REAL*8(A-H,O-Z) 1231C *** 1232C 1233C CANG RETURNS THE PHASE ANGLE OF A COMPLEX NUMBER IN DEGREES. 1234C 1235 COMPLEX*16 Z 1236 CANG=ATGN2(DIMAG(Z),DREAL(Z))*57.29577951D+0 1237 RETURN 1238 END 1239 SUBROUTINE CMNGF (CB,CC,CD,NB,NC,ND,RKHX,IEXKX) 1240C *** 1241C DOUBLE PRECISION 6/4/85 1242C 1243 PARAMETER (MAXSEG=1500, MAXMAT=1500) 1244 IMPLICIT REAL*8(A-H,O-Z) 1245C *** 1246C CMNGF FILLS INTERACTION MATRICIES B, C, AND D FOR N.G.F. SOLUTION 1247 COMPLEX*16 CB,CC,CD,ZARRAY,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC 1248 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 1249 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 1250 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 1251 COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF 1252 COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP 1253 1CON(10),NPCON 1254 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 1255 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 1256 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 1257 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 1258 DIMENSION CB(NB,1), CC(NC,1), CD(ND,1) 1259 RKH=RKHX 1260 IEXK=IEXKX 1261 M1EQ=2*M1 1262 M2EQ=M1EQ+1 1263 MEQ=2*M 1264 NEQP=ND-NPCON*2 1265 NEQS=NEQP-NSCON 1266 NEQSP=NEQS+NC 1267 NEQN=NC+N-N1 1268 ITX=1 1269 IF (NSCON.GT.0) ITX=2 1270 IF (ICASX.EQ.1) GO TO 1 1271 REWIND 12 1272 REWIND 14 1273 REWIND 15 1274 IF (ICASX.GT.2) GO TO 5 12751 DO 4 J=1,ND 1276 DO 2 I=1,ND 12772 CD(I,J)=(0.,0.) 1278 DO 3 I=1,NB 1279 CB(I,J)=(0.,0.) 12803 CC(I,J)=(0.,0.) 12814 CONTINUE 12825 IST=N-N1+1 1283 IT=NPBX 1284 ISV=-NPBX 1285C LOOP THRU 24 FILLS B. FOR ICASX=1 OR 2 ALSO FILLS D(WW), D(WS) 1286 DO 24 IBLK=1,NBBX 1287 ISV=ISV+NPBX 1288 IF (IBLK.EQ.NBBX) IT=NLBX 1289 IF (ICASX.LT.3) GO TO 7 1290 DO 6 J=1,ND 1291 DO 6 I=1,IT 12926 CB(I,J)=(0.,0.) 12937 I1=ISV+1 1294 I2=ISV+IT 1295 IN2=I2 1296 IF (IN2.GT.N1) IN2=N1 1297 IM1=I1-N1 1298 IM2=I2-N1 1299 IF (IM1.LT.1) IM1=1 1300 IMX=1 1301 IF (I1.LE.N1) IMX=N1-I1+2 1302 IF (N2.GT.N) GO TO 12 1303C FILL B(WW),B(WS). FOR ICASX=1,2 FILL D(WW),D(WS) 1304 DO 11 J=N2,N 1305 CALL TRIO (J) 1306 DO 9 I=1,JSNO 1307 JSS=JCO(I) 1308 IF (JSS.LT.N2) GO TO 8 1309C SET JCO WHEN SOURCE IS NEW BASIS FUNCTION ON NEW SEGMENT 1310 JCO(I)=JSS-N1 1311 GO TO 9 1312C SOURCE IS PORTION OF MODIFIED BASIS FUNCTION ON NEW SEGMENT 13138 JCO(I)=NEQS+ICONX(JSS) 13149 CONTINUE 1315 IF (I1.LE.IN2) CALL CMWW (J,I1,IN2,CB,NB,CB,NB,0) 1316 IF (IM1.LE.IM2) CALL CMWS (J,IM1,IM2,CB(IMX,1),NB,CB,NB,0) 1317 IF (ICASX.GT.2) GO TO 11 1318 CALL CMWW (J,N2,N,CD,ND,CD,ND,1) 1319 IF (M2.LE.M) CALL CMWS (J,M2EQ,MEQ,CD(1,IST),ND,CD,ND,1) 1320C LOADING IN D(WW) 1321 IF (NLOAD.EQ.0) GO TO 11 1322 IR=J-N1 1323 EXK=ZARRAY(J) 1324 DO 10 I=1,JSNO 1325 JSS=JCO(I) 132610 CD(JSS,IR)=CD(JSS,IR)-(AX(I)+CX(I))*EXK 132711 CONTINUE 132812 IF (NSCON.EQ.0) GO TO 20 1329C FILL B(WW)PRIME 1330 DO 19 I=1,NSCON 1331 J=ISCON(I) 1332C SOURCES ARE NEW OR MODIFIED BASIS FUNCTIONS ON OLD SEGMENTS WHICH 1333C CONNECT TO NEW SEGMENTS 1334 CALL TRIO (J) 1335 JSS=0 1336 DO 15 IX=1,JSNO 1337 IR=JCO(IX) 1338 IF (IR.LT.N2) GO TO 13 1339 IR=IR-N1 1340 GO TO 14 134113 IR=ICONX(IR) 1342 IF (IR.EQ.0) GO TO 15 1343 IR=NEQS+IR 134414 JSS=JSS+1 1345 JCO(JSS)=IR 1346 AX(JSS)=AX(IX) 1347 BX(JSS)=BX(IX) 1348 CX(JSS)=CX(IX) 134915 CONTINUE 1350 JSNO=JSS 1351 IF (I1.LE.IN2) CALL CMWW (J,I1,IN2,CB,NB,CB,NB,0) 1352 IF (IM1.LE.IM2) CALL CMWS (J,IM1,IM2,CB(IMX,1),NB,CB,NB,0) 1353C SOURCE IS SINGULAR COMPONENT OF PATCH CURRENT THAT IS PART OF 1354C MODIFIED BASIS FUNCTION FOR OLD SEGMENT THAT CONNECTS TO A NEW 1355C SEGMENT ON END OPPOSITE PATCH. 1356 IF (I1.LE.IN2) CALL CMSW (J,I,I1,IN2,CB,CB,0,NB,-1) 1357 IF (NLODF.EQ.0) GO TO 17 1358 JX=J-ISV 1359 IF (JX.LT.1.OR.JX.GT.IT) GO TO 17 1360 EXK=ZARRAY(J) 1361 DO 16 IX=1,JSNO 1362 JSS=JCO(IX) 136316 CB(JX,JSS)=CB(JX,JSS)-(AX(IX)+CX(IX))*EXK 1364C SOURCES ARE PORTIONS OF MODIFIED BASIS FUNCTION J ON OLD SEGMENTS 1365C EXCLUDING OLD SEGMENTS THAT DIRECTLY CONNECT TO NEW SEGMENTS. 136617 CALL TBF (J,1) 1367 JSX=JSNO 1368 JSNO=1 1369 IR=JCO(1) 1370 JCO(1)=NEQS+I 1371 DO 19 IX=1,JSX 1372 IF (IX.EQ.1) GO TO 18 1373 IR=JCO(IX) 1374 AX(1)=AX(IX) 1375 BX(1)=BX(IX) 1376 CX(1)=CX(IX) 137718 IF (IR.GT.N1) GO TO 19 1378 IF (ICONX(IR).NE.0) GO TO 19 1379 IF (I1.LE.IN2) CALL CMWW (IR,I1,IN2,CB,NB,CB,NB,0) 1380 IF (IM1.LE.IM2) CALL CMWS (IR,IM1,IM2,CB(IMX,1),NB,CB,NB,0) 1381C LOADING FOR B(WW)PRIME 1382 IF (NLODF.EQ.0) GO TO 19 1383 JX=IR-ISV 1384 IF (JX.LT.1.OR.JX.GT.IT) GO TO 19 1385 EXK=ZARRAY(IR) 1386 JSS=JCO(1) 1387 CB(JX,JSS)=CB(JX,JSS)-(AX(1)+CX(1))*EXK 138819 CONTINUE 138920 IF (NPCON.EQ.0) GO TO 22 1390 JSS=NEQP 1391C FILL B(SS)PRIME TO SET OLD PATCH BASIS FUNCTIONS TO ZERO FOR 1392C PATCHES THAT CONNECT TO NEW SEGMENTS 1393 DO 21 I=1,NPCON 1394 IX=IPCON(I)*2+N1-ISV 1395 IR=IX-1 1396 JSS=JSS+1 1397 IF (IR.GT.0.AND.IR.LE.IT) CB(IR,JSS)=(1.,0.) 1398 JSS=JSS+1 1399 IF (IX.GT.0.AND.IX.LE.IT) CB(IX,JSS)=(1.,0.) 140021 CONTINUE 140122 IF (M2.GT.M) GO TO 23 1402C FILL B(SW) AND B(SS) 1403 IF (I1.LE.IN2) CALL CMSW (M2,M,I1,IN2,CB(1,IST),CB,N1,NB,0) 1404 IF (IM1.LE.IM2) CALL CMSS (M2,M,IM1,IM2,CB(IMX,IST),NB,0) 140523 IF (ICASX.EQ.1) GO TO 24 1406 WRITE (14) ((CB(I,J),I=1,IT),J=1,ND) 140724 CONTINUE 1408C FILLING B COMPLETE. START ON C AND D 1409 IT=NPBL 1410 ISV=-NPBL 1411 DO 43 IBLK=1,NBBL 1412 ISV=ISV+NPBL 1413 ISVV=ISV+NC 1414 IF (IBLK.EQ.NBBL) IT=NLBL 1415 IF (ICASX.LT.3) GO TO 27 1416 DO 26 J=1,IT 1417 DO 25 I=1,NC 141825 CC(I,J)=(0.,0.) 1419 DO 26 I=1,ND 142026 CD(I,J)=(0.,0.) 142127 I1=ISVV+1 1422 I2=ISVV+IT 1423 IN1=I1-M1EQ 1424 IN2=I2-M1EQ 1425 IF (IN2.GT.N) IN2=N 1426 IM1=I1-N 1427 IM2=I2-N 1428 IF (IM1.LT.M2EQ) IM1=M2EQ 1429 IF (IM2.GT.MEQ) IM2=MEQ 1430 IMX=1 1431 IF (IN1.LE.IN2) IMX=NEQN-I1+2 1432 IF (ICASX.LT.3) GO TO 32 1433 IF (N2.GT.N) GO TO 32 1434C SAME AS DO 24 LOOP TO FILL D(WW) FOR ICASX GREATER THAN 2 1435 DO 31 J=N2,N 1436 CALL TRIO (J) 1437 DO 29 I=1,JSNO 1438 JSS=JCO(I) 1439 IF (JSS.LT.N2) GO TO 28 1440 JCO(I)=JSS-N1 1441 GO TO 29 144228 JCO(I)=NEQS+ICONX(JSS) 144329 CONTINUE 1444 IF (IN1.LE.IN2) CALL CMWW (J,IN1,IN2,CD,ND,CD,ND,1) 1445 IF (IM1.LE.IM2) CALL CMWS (J,IM1,IM2,CD(1,IMX),ND,CD,ND,1) 1446 IF (NLOAD.EQ.0) GO TO 31 1447 IR=J-N1-ISV 1448 IF (IR.LT.1.OR.IR.GT.IT) GO TO 31 1449 EXK=ZARRAY(J) 1450 DO 30 I=1,JSNO 1451 JSS=JCO(I) 145230 CD(JSS,IR)=CD(JSS,IR)-(AX(I)+CX(I))*EXK 145331 CONTINUE 145432 IF (M2.GT.M) GO TO 33 1455C FILL D(SW) AND D(SS) 1456 IF (IN1.LE.IN2) CALL CMSW (M2,M,IN1,IN2,CD(IST,1),CD,N1,ND,1) 1457 IF (IM1.LE.IM2) CALL CMSS (M2,M,IM1,IM2,CD(IST,IMX),ND,1) 145833 IF (N1.LT.1) GO TO 39 1459C FILL C(WW),C(WS), D(WW)PRIME, AND D(WS)PRIME. 1460 DO 37 J=1,N1 1461 CALL TRIO (J) 1462 IF (NSCON.EQ.0) GO TO 36 1463 DO 35 IX=1,JSNO 1464 JSS=JCO(IX) 1465 IF (JSS.LT.N2) GO TO 34 1466 JCO(IX)=JSS+M1EQ 1467 GO TO 35 146834 IR=ICONX(JSS) 1469 IF (IR.NE.0) JCO(IX)=NEQSP+IR 147035 CONTINUE 147136 IF (IN1.LE.IN2) CALL CMWW (J,IN1,IN2,CC,NC,CD,ND,ITX) 1472 IF (IM1.LE.IM2) CALL CMWS (J,IM1,IM2,CC(1,IMX),NC,CD(1,IMX),ND,ITX 1473 1) 147437 CONTINUE 1475 IF (NSCON.EQ.0) GO TO 39 1476C FILL C(WW)PRIME 1477 DO 38 IX=1,NSCON 1478 IR=ISCON(IX) 1479 JSS=NEQS+IX-ISV 1480 IF (JSS.GT.0.AND.JSS.LE.IT) CC(IR,JSS)=(1.,0.) 148138 CONTINUE 148239 IF (NPCON.EQ.0) GO TO 41 1483 JSS=NEQP-ISV 1484C FILL C(SS)PRIME 1485 DO 40 I=1,NPCON 1486 IX=IPCON(I)*2+N1 1487 IR=IX-1 1488 JSS=JSS+1 1489 IF (JSS.GT.0.AND.JSS.LE.IT) CC(IR,JSS)=(1.,0.) 1490 JSS=JSS+1 1491 IF (JSS.GT.0.AND.JSS.LE.IT) CC(IX,JSS)=(1.,0.) 149240 CONTINUE 149341 IF (M1.LT.1) GO TO 42 1494C FILL C(SW) AND C(SS) 1495 IF (IN1.LE.IN2) CALL CMSW (1,M1,IN1,IN2,CC(N2,1),CC,0,NC,1) 1496 IF (IM1.LE.IM2) CALL CMSS (1,M1,IM1,IM2,CC(N2,IMX),NC,1) 149742 CONTINUE 1498 IF (ICASX.EQ.1) GO TO 43 1499 WRITE (12) ((CD(J,I),J=1,ND),I=1,IT) 1500 WRITE (15) ((CC(J,I),J=1,NC),I=1,IT) 150143 CONTINUE 1502 IF(ICASX.EQ.1)RETURN 1503 REWIND 12 1504 REWIND 14 1505 REWIND 15 1506 RETURN 1507 END 1508 SUBROUTINE CMSET (NROW,CM,RKHX,IEXKX) 1509C *** 1510C DOUBLE PRECISION 6/4/85 1511C 1512 PARAMETER (MAXSEG=1500, MAXMAT=1500) 1513 IMPLICIT REAL*8(A-H,O-Z) 1514C *** 1515C 1516C CMSET SETS UP THE COMPLEX STRUCTURE MATRIX IN THE ARRAY CM 1517C 1518 COMPLEX*16 CM,ZARRAY,ZAJ,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,SSX, 1519 &D,DETER 1520 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 1521 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 1522 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 1523 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 1524 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 1525 COMMON /SMAT/ SSX(16,16) 1526 COMMON /SCRATM/ D(2*MAXSEG) 1527 COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF 1528 COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP 1529 1CON(10),NPCON 1530 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 1531 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 1532 DIMENSION CM(NROW,1) 1533 MP2=2*MP 1534 NPEQ=NP+MP2 1535 NEQ=N+2*M 1536 NOP=NEQ/NPEQ 1537 IF (ICASE.GT.2) REWIND 11 1538 RKH=RKHX 1539 IEXK=IEXKX 1540 IOUT=2*NPBLK*NROW 1541 IT=NPBLK 1542C 1543C CYCLE OVER MATRIX BLOCKS 1544C 1545 DO 13 IXBLK1=1,NBLOKS 1546 ISV=(IXBLK1-1)*NPBLK 1547 IF (IXBLK1.EQ.NBLOKS) IT=NLAST 1548 DO 1 I=1,NROW 1549 DO 1 J=1,IT 15501 CM(I,J)=(0.,0.) 1551 I1=ISV+1 1552 I2=ISV+IT 1553 IN2=I2 1554 IF (IN2.GT.NP) IN2=NP 1555 IM1=I1-NP 1556 IM2=I2-NP 1557 IF (IM1.LT.1) IM1=1 1558 IST=1 1559 IF (I1.LE.NP) IST=NP-I1+2 1560 IF (N.EQ.0) GO TO 5 1561C 1562C WIRE SOURCE LOOP 1563C 1564 DO 4 J=1,N 1565 CALL TRIO (J) 1566 DO 2 I=1,JSNO 1567 IJ=JCO(I) 15682 JCO(I)=((IJ-1)/NP)*MP2+IJ 1569 IF (I1.LE.IN2) CALL CMWW (J,I1,IN2,CM,NROW,CM,NROW,1) 1570 IF (IM1.LE.IM2) CALL CMWS (J,IM1,IM2,CM(1,IST),NROW,CM,NROW,1) 1571 IF (NLOAD.EQ.0) GO TO 4 1572C 1573C MATRIX ELEMENTS MODIFIED BY LOADING 1574C 1575 IF (J.GT.NP) GO TO 4 1576 IPR=J-ISV 1577 IF (IPR.LT.1.OR.IPR.GT.IT) GO TO 4 1578 ZAJ=ZARRAY(J) 1579 DO 3 I=1,JSNO 1580 JSS=JCO(I) 15813 CM(JSS,IPR)=CM(JSS,IPR)-(AX(I)+CX(I))*ZAJ 15824 CONTINUE 15835 IF (M.EQ.0) GO TO 7 1584C MATRIX ELEMENTS FOR PATCH CURRENT SOURCES 1585 JM1=1-MP 1586 JM2=0 1587 JST=1-MP2 1588 DO 6 I=1,NOP 1589 JM1=JM1+MP 1590 JM2=JM2+MP 1591 JST=JST+NPEQ 1592 IF (I1.LE.IN2) CALL CMSW (JM1,JM2,I1,IN2,CM(JST,1),CM,0,NROW,1) 1593 IF (IM1.LE.IM2) CALL CMSS (JM1,JM2,IM1,IM2,CM(JST,IST),NROW,1) 15946 CONTINUE 15957 IF (ICASE.EQ.1) GO TO 13 1596 IF (ICASE.EQ.3) GO TO 12 1597C COMBINE ELEMENTS FOR SYMMETRY MODES 1598 DO 11 I=1,IT 1599 DO 11 J=1,NPEQ 1600 DO 8 K=1,NOP 1601 KA=J+(K-1)*NPEQ 16028 D(K)=CM(KA,I) 1603 DETER=D(1) 1604 DO 9 KK=2,NOP 16059 DETER=DETER+D(KK) 1606 CM(J,I)=DETER 1607 DO 11 K=2,NOP 1608 KA=J+(K-1)*NPEQ 1609 DETER=D(1) 1610 DO 10 KK=2,NOP 161110 DETER=DETER+D(KK)*SSX(K,KK) 1612 CM(KA,I)=DETER 161311 CONTINUE 1614 IF (ICASE.LT.3) GO TO 13 1615C WRITE BLOCK FOR OUT-OF-CORE CASES. 161612 CALL BLCKOT (CM,11,1,IOUT,1,31) 161713 CONTINUE 1618 IF (ICASE.GT.2) REWIND 11 1619 RETURN 1620 END 1621 SUBROUTINE CMSS (J1,J2,IM1,IM2,CM,NROW,ITRP) 1622C *** 1623C DOUBLE PRECISION 6/4/85 1624C 1625 PARAMETER (MAXSEG=1500, MAXMAT=1500) 1626 IMPLICIT REAL*8(A-H,O-Z) 1627C *** 1628C CMSS COMPUTES MATRIX ELEMENTS FOR SURFACE-SURFACE INTERACTIONS. 1629 COMPLEX*16 G11,G12,G21,G22,CM,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC 1630 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 1631 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 1632 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 1633 COMMON /ANGL/ SALP(MAXSEG) 1634 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 1635 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 1636 DIMENSION CM(NROW,1) 1637 DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) 1638 EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON 1639 12), (T2Z,ITAG) 1640 EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y 1641 1J,IND1), (T2ZJ,IND2) 1642 LDP=LD+1 1643 I1=(IM1+1)/2 1644 I2=(IM2+1)/2 1645 ICOMP=I1*2-3 1646 II1=-1 1647 IF (ICOMP+2.LT.IM1) II1=-2 1648C LOOP OVER OBSERVATION PATCHES 1649 DO 5 I=I1,I2 1650 IL=LDP-I 1651 ICOMP=ICOMP+2 1652 II1=II1+2 1653 II2=II1+1 1654 T1XI=T1X(IL)*SALP(IL) 1655 T1YI=T1Y(IL)*SALP(IL) 1656 T1ZI=T1Z(IL)*SALP(IL) 1657 T2XI=T2X(IL)*SALP(IL) 1658 T2YI=T2Y(IL)*SALP(IL) 1659 T2ZI=T2Z(IL)*SALP(IL) 1660 XI=X(IL) 1661 YI=Y(IL) 1662 ZI=Z(IL) 1663 JJ1=-1 1664C LOOP OVER SOURCE PATCHES 1665 DO 5 J=J1,J2 1666 JL=LDP-J 1667 JJ1=JJ1+2 1668 JJ2=JJ1+1 1669 S=BI(JL) 1670 XJ=X(JL) 1671 YJ=Y(JL) 1672 ZJ=Z(JL) 1673 T1XJ=T1X(JL) 1674 T1YJ=T1Y(JL) 1675 T1ZJ=T1Z(JL) 1676 T2XJ=T2X(JL) 1677 T2YJ=T2Y(JL) 1678 T2ZJ=T2Z(JL) 1679 CALL HINTG (XI,YI,ZI) 1680 G11=-(T2XI*EXK+T2YI*EYK+T2ZI*EZK) 1681 G12=-(T2XI*EXS+T2YI*EYS+T2ZI*EZS) 1682 G21=-(T1XI*EXK+T1YI*EYK+T1ZI*EZK) 1683 G22=-(T1XI*EXS+T1YI*EYS+T1ZI*EZS) 1684 IF (I.NE.J) GO TO 1 1685 G11=G11-.5 1686 G22=G22+.5 16871 IF (ITRP.NE.0) GO TO 3 1688C NORMAL FILL 1689 IF (ICOMP.LT.IM1) GO TO 2 1690 CM(II1,JJ1)=G11 1691 CM(II1,JJ2)=G12 16922 IF (ICOMP.GE.IM2) GO TO 5 1693 CM(II2,JJ1)=G21 1694 CM(II2,JJ2)=G22 1695 GO TO 5 1696C TRANSPOSED FILL 16973 IF (ICOMP.LT.IM1) GO TO 4 1698 CM(JJ1,II1)=G11 1699 CM(JJ2,II1)=G12 17004 IF (ICOMP.GE.IM2) GO TO 5 1701 CM(JJ1,II2)=G21 1702 CM(JJ2,II2)=G22 17035 CONTINUE 1704 RETURN 1705 END 1706 SUBROUTINE CMSW (J1,J2,I1,I2,CM,CW,NCW,NROW,ITRP) 1707C *** 1708C DOUBLE PRECISION 6/4/85 1709C 1710 PARAMETER (MAXSEG=1500, MAXMAT=1500) 1711 IMPLICIT REAL*8(A-H,O-Z) 1712C *** 1713C COMPUTES MATRIX ELEMENTS FOR E ALONG WIRES DUE TO PATCH CURRENT 1714 COMPLEX*16 CM,ZRATI,ZRATI2,T1,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC 1715 1,EMEL,CW,FRATI 1716 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 1717 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 1718 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 1719 COMMON /ANGL/ SALP(MAXSEG) 1720 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 1721 &KSYMP,IFAR,IPERF 1722 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 1723 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 1724 COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP 1725 1CON(10),NPCON 1726 DIMENSION CAB(1), SAB(1), CM(NROW,1), CW(NROW,1) 1727 DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), EMEL(9) 1728 EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON 1729 12), (T2Z,ITAG), (CAB,ALP), (SAB,BET) 1730 EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y 1731 1J,IND1), (T2ZJ,IND2) 1732 DATA PI/3.141592654D+0/ 1733 LDP=LD+1 1734 NEQS=N-N1+2*(M-M1) 1735 IF (ITRP.LT.0) GO TO 13 1736 K=0 1737 ICGO=1 1738C OBSERVATION LOOP 1739 DO 12 I=I1,I2 1740 K=K+1 1741 XI=X(I) 1742 YI=Y(I) 1743 ZI=Z(I) 1744 CABI=CAB(I) 1745 SABI=SAB(I) 1746 SALPI=SALP(I) 1747 IPCH=0 1748 IF (ICON1(I).LT.10000) GO TO 1 1749 IPCH=ICON1(I)-10000 1750 FSIGN=-1. 17511 IF (ICON2(I).LT.10000) GO TO 2 1752 IPCH=ICON2(I)-10000 1753 FSIGN=1. 17542 JL=0 1755C SOURCE LOOP 1756 DO 12 J=J1,J2 1757 JS=LDP-J 1758 JL=JL+2 1759 T1XJ=T1X(JS) 1760 T1YJ=T1Y(JS) 1761 T1ZJ=T1Z(JS) 1762 T2XJ=T2X(JS) 1763 T2YJ=T2Y(JS) 1764 T2ZJ=T2Z(JS) 1765 XJ=X(JS) 1766 YJ=Y(JS) 1767 ZJ=Z(JS) 1768 S=BI(JS) 1769C GROUND LOOP 1770 DO 12 IP=1,KSYMP 1771 IPGND=IP 1772 IF (IPCH.NE.J.AND.ICGO.EQ.1) GO TO 9 1773 IF (IP.EQ.2) GO TO 9 1774 IF (ICGO.GT.1) GO TO 6 1775 CALL PCINT (XI,YI,ZI,CABI,SABI,SALPI,EMEL) 1776 PY=PI*SI(I)*FSIGN 1777 PX=SIN(PY) 1778 PY=COS(PY) 1779 EXC=EMEL(9)*FSIGN 1780 CALL TRIO (I) 1781 IF (I.GT.N1) GO TO 3 1782 IL=NEQS+ICONX(I) 1783 GO TO 4 17843 IL=I-NCW 1785 IF (I.LE.NP) IL=((IL-1)/NP)*2*MP+IL 17864 IF (ITRP.NE.0) GO TO 5 1787 CW(K,IL)=CW(K,IL)+EXC*(AX(JSNO)+BX(JSNO)*PX+CX(JSNO)*PY) 1788 GO TO 6 17895 CW(IL,K)=CW(IL,K)+EXC*(AX(JSNO)+BX(JSNO)*PX+CX(JSNO)*PY) 17906 IF (ITRP.NE.0) GO TO 7 1791 CM(K,JL-1)=EMEL(ICGO) 1792 CM(K,JL)=EMEL(ICGO+4) 1793 GO TO 8 17947 CM(JL-1,K)=EMEL(ICGO) 1795 CM(JL,K)=EMEL(ICGO+4) 17968 ICGO=ICGO+1 1797 IF (ICGO.EQ.5) ICGO=1 1798 GO TO 11 17999 CALL UNERE (XI,YI,ZI) 1800 IF (ITRP.NE.0) GO TO 10 1801C NORMAL FILL 1802 CM(K,JL-1)=CM(K,JL-1)+EXK*CABI+EYK*SABI+EZK*SALPI 1803 CM(K,JL)=CM(K,JL)+EXS*CABI+EYS*SABI+EZS*SALPI 1804 GO TO 11 1805C TRANSPOSED FILL 180610 CM(JL-1,K)=CM(JL-1,K)+EXK*CABI+EYK*SABI+EZK*SALPI 1807 CM(JL,K)=CM(JL,K)+EXS*CABI+EYS*SABI+EZS*SALPI 180811 CONTINUE 180912 CONTINUE 1810 RETURN 1811C FOR OLD SEG. CONNECTING TO OLD PATCH ON ONE END AND NEW SEG. ON 1812C OTHER END INTEGRATE SINGULAR COMPONENT (9) OF SURFACE CURRENT ONLY 181313 IF (J1.LT.I1.OR.J1.GT.I2) GO TO 16 1814 IPCH=ICON1(J1) 1815 IF (IPCH.LT.10000) GO TO 14 1816 IPCH=IPCH-10000 1817 FSIGN=-1. 1818 GO TO 15 181914 IPCH=ICON2(J1) 1820 IF (IPCH.LT.10000) GO TO 16 1821 IPCH=IPCH-10000 1822 FSIGN=1. 182315 IF (IPCH.GT.M1) GO TO 16 1824 JS=LDP-IPCH 1825 IPGND=1 1826 T1XJ=T1X(JS) 1827 T1YJ=T1Y(JS) 1828 T1ZJ=T1Z(JS) 1829 T2XJ=T2X(JS) 1830 T2YJ=T2Y(JS) 1831 T2ZJ=T2Z(JS) 1832 XJ=X(JS) 1833 YJ=Y(JS) 1834 ZJ=Z(JS) 1835 S=BI(JS) 1836 XI=X(J1) 1837 YI=Y(J1) 1838 ZI=Z(J1) 1839 CABI=CAB(J1) 1840 SABI=SAB(J1) 1841 SALPI=SALP(J1) 1842 CALL PCINT (XI,YI,ZI,CABI,SABI,SALPI,EMEL) 1843 PY=PI*SI(J1)*FSIGN 1844 PX=SIN(PY) 1845 PY=COS(PY) 1846 EXC=EMEL(9)*FSIGN 1847 IL=JCO(JSNO) 1848 K=J1-I1+1 1849 CW(K,IL)=CW(K,IL)+EXC*(AX(JSNO)+BX(JSNO)*PX+CX(JSNO)*PY) 185016 RETURN 1851 END 1852 SUBROUTINE CMWS (J,I1,I2,CM,NR,CW,NW,ITRP) 1853C *** 1854C DOUBLE PRECISION 6/4/85 1855C 1856 PARAMETER (MAXSEG=1500, MAXMAT=1500) 1857 IMPLICIT REAL*8(A-H,O-Z) 1858C *** 1859C 1860C CMWS COMPUTES MATRIX ELEMENTS FOR WIRE-SURFACE INTERACTIONS 1861C 1862 COMPLEX*16 CM,CW,ETK,ETS,ETC,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC 1863 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 1864 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 1865 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 1866 COMMON /ANGL/ SALP(MAXSEG) 1867 COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP 1868 1CON(10),NPCON 1869 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 1870 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 1871 DIMENSION CM(NR,1), CW(NW,1), CAB(1), SAB(1) 1872 DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) 1873 EQUIVALENCE (CAB,ALP), (SAB,BET), (T1X,SI), (T1Y,ALP), (T1Z,BET) 1874 EQUIVALENCE (T2X,ICON1), (T2Y,ICON2), (T2Z,ITAG) 1875 LDP=LD+1 1876 S=SI(J) 1877 B=BI(J) 1878 XJ=X(J) 1879 YJ=Y(J) 1880 ZJ=Z(J) 1881 CABJ=CAB(J) 1882 SABJ=SAB(J) 1883 SALPJ=SALP(J) 1884C 1885C OBSERVATION LOOP 1886C 1887 IPR=0 1888 DO 9 I=I1,I2 1889 IPR=IPR+1 1890 IPATCH=(I+1)/2 1891 IK=I-(I/2)*2 1892 IF (IK.EQ.0.AND.IPR.NE.1) GO TO 1 1893 JS=LDP-IPATCH 1894 XI=X(JS) 1895 YI=Y(JS) 1896 ZI=Z(JS) 1897 CALL HSFLD (XI,YI,ZI,0.D0) 1898 IF (IK.EQ.0) GO TO 1 1899 TX=T2X(JS) 1900 TY=T2Y(JS) 1901 TZ=T2Z(JS) 1902 GO TO 2 19031 TX=T1X(JS) 1904 TY=T1Y(JS) 1905 TZ=T1Z(JS) 19062 ETK=-(EXK*TX+EYK*TY+EZK*TZ)*SALP(JS) 1907 ETS=-(EXS*TX+EYS*TY+EZS*TZ)*SALP(JS) 1908 ETC=-(EXC*TX+EYC*TY+EZC*TZ)*SALP(JS) 1909C 1910C FILL MATRIX ELEMENTS. ELEMENT LOCATIONS DETERMINED BY CONNECTION 1911C DATA. 1912C 1913 IF (ITRP.NE.0) GO TO 4 1914C NORMAL FILL 1915 DO 3 IJ=1,JSNO 1916 JX=JCO(IJ) 19173 CM(IPR,JX)=CM(IPR,JX)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ) 1918 GO TO 9 19194 IF (ITRP.EQ.2) GO TO 6 1920C TRANSPOSED FILL 1921 DO 5 IJ=1,JSNO 1922 JX=JCO(IJ) 19235 CM(JX,IPR)=CM(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ) 1924 GO TO 9 1925C TRANSPOSED FILL - C(WS) AND D(WS)PRIME (=CW) 19266 DO 8 IJ=1,JSNO 1927 JX=JCO(IJ) 1928 IF (JX.GT.NR) GO TO 7 1929 CM(JX,IPR)=CM(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ) 1930 GO TO 8 19317 JX=JX-NR 1932 CW(JX,IPR)=CW(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ) 19338 CONTINUE 19349 CONTINUE 1935 RETURN 1936 END 1937 SUBROUTINE CMWW (J,I1,I2,CM,NR,CW,NW,ITRP) 1938C *** 1939C DOUBLE PRECISION 6/4/85 1940C 1941 PARAMETER (MAXSEG=1500, MAXMAT=1500) 1942 IMPLICIT REAL*8(A-H,O-Z) 1943C *** 1944C 1945C CMWW COMPUTES MATRIX ELEMENTS FOR WIRE-WIRE INTERACTIONS 1946C 1947 COMPLEX*16 CM,CW,ETK,ETS,ETC,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC 1948 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 1949 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 1950 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 1951 COMMON /ANGL/ SALP(MAXSEG) 1952 COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP 1953 1CON(10),NPCON 1954 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 1955 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 1956 DIMENSION CM(NR,1), CW(NW,1), CAB(1), SAB(1) 1957 EQUIVALENCE (CAB,ALP), (SAB,BET) 1958C SET SOURCE SEGMENT PARAMETERS 1959 S=SI(J) 1960 B=BI(J) 1961 XJ=X(J) 1962 YJ=Y(J) 1963 ZJ=Z(J) 1964 CABJ=CAB(J) 1965 SABJ=SAB(J) 1966 SALPJ=SALP(J) 1967 IF (IEXK.EQ.0) GO TO 16 1968C DECIDE WETHER EXT. T.W. APPROX. CAN BE USED 1969 IPR=ICON1(J) 1970 IF (IPR) 1,6,2 19711 IPR=-IPR 1972 IF (-ICON1(IPR).NE.J) GO TO 7 1973 GO TO 4 19742 IF (IPR.NE.J) GO TO 3 1975 IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 7 1976 GO TO 5 19773 IF (ICON2(IPR).NE.J) GO TO 7 19784 XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR)) 1979 IF (XI.LT.0.999999D+0) GO TO 7 1980 IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 7 19815 IND1=0 1982 GO TO 8 19836 IND1=1 1984 GO TO 8 19857 IND1=2 19868 IPR=ICON2(J) 1987 IF (IPR) 9,14,10 19889 IPR=-IPR 1989 IF (-ICON2(IPR).NE.J) GO TO 15 1990 GO TO 12 199110 IF (IPR.NE.J) GO TO 11 1992 IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 15 1993 GO TO 13 199411 IF (ICON1(IPR).NE.J) GO TO 15 199512 XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR)) 1996 IF (XI.LT.0.999999D+0) GO TO 15 1997 IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 15 199813 IND2=0 1999 GO TO 16 200014 IND2=1 2001 GO TO 16 200215 IND2=2 200316 CONTINUE 2004C 2005C OBSERVATION LOOP 2006C 2007 IPR=0 2008 DO 23 I=I1,I2 2009 IPR=IPR+1 2010 IJ=I-J 2011 XI=X(I) 2012 YI=Y(I) 2013 ZI=Z(I) 2014 AI=BI(I) 2015 CABI=CAB(I) 2016 SABI=SAB(I) 2017 SALPI=SALP(I) 2018 CALL EFLD (XI,YI,ZI,AI,IJ) 2019 ETK=EXK*CABI+EYK*SABI+EZK*SALPI 2020 ETS=EXS*CABI+EYS*SABI+EZS*SALPI 2021 ETC=EXC*CABI+EYC*SABI+EZC*SALPI 2022C 2023C FILL MATRIX ELEMENTS. ELEMENT LOCATIONS DETERMINED BY CONNECTION 2024C DATA. 2025C 2026 IF (ITRP.NE.0) GO TO 18 2027C NORMAL FILL 2028 DO 17 IJ=1,JSNO 2029 JX=JCO(IJ) 203017 CM(IPR,JX)=CM(IPR,JX)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ) 2031 GO TO 23 203218 IF (ITRP.EQ.2) GO TO 20 2033C TRANSPOSED FILL 2034 DO 19 IJ=1,JSNO 2035 JX=JCO(IJ) 203619 CM(JX,IPR)=CM(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ) 2037 GO TO 23 2038C TRANS. FILL FOR C(WW) - TEST FOR ELEMENTS FOR D(WW)PRIME. (=CW) 203920 DO 22 IJ=1,JSNO 2040 JX=JCO(IJ) 2041 IF (JX.GT.NR) GO TO 21 2042 CM(JX,IPR)=CM(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ) 2043 GO TO 22 204421 JX=JX-NR 2045 CW(JX,IPR)=CW(JX,IPR)+ETK*AX(IJ)+ETS*BX(IJ)+ETC*CX(IJ) 204622 CONTINUE 204723 CONTINUE 2048 RETURN 2049 END 2050 SUBROUTINE CONECT (IGND) 2051C *** 2052C DOUBLE PRECISION 6/4/85 2053C 2054 PARAMETER (MAXSEG=1500, MAXMAT=1500) 2055 IMPLICIT REAL*8(A-H,O-Z) 2056C *** 2057C 2058C CONNECT SETS UP SEGMENT CONNECTION DATA IN ARRAYS ICON1 AND ICON2 2059C BY SEARCHING FOR SEGMENT ENDS THAT ARE IN CONTACT. 2060C 2061 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 2062 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 2063 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 2064 COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP 2065 1CON(10),NPCON 2066 DIMENSION X2(1), Y2(1), Z2(1) 2067 EQUIVALENCE (X2,SI), (Y2,ALP), (Z2,BET) 2068 DATA JMAX/30/,SMIN/1.D-3/,NSMAX/50/,NPMAX/10/ 2069 NSCON=0 2070 NPCON=0 2071 IF (IGND.EQ.0) GO TO 3 2072 WRITE(3,54) 2073 IF (IGND.GT.0) WRITE(3,55) 2074 IF (IPSYM.NE.2) GO TO 1 2075 NP=2*NP 2076 MP=2*MP 20771 IF (IABS(IPSYM).LE.2) GO TO 2 2078 NP=N 2079 MP=M 20802 IF (NP.GT.N) STOP 2081 IF (NP.EQ.N.AND.MP.EQ.M) IPSYM=0 20823 IF (N.EQ.0) GO TO 26 2083 DO 15 I=1,N 2084 ICONX(I)=0 2085 XI1=X(I) 2086 YI1=Y(I) 2087 ZI1=Z(I) 2088 XI2=X2(I) 2089 YI2=Y2(I) 2090 ZI2=Z2(I) 2091 SLEN=SQRT((XI2-XI1)**2+(YI2-YI1)**2+(ZI2-ZI1)**2)*SMIN 2092C 2093C DETERMINE CONNECTION DATA FOR END 1 OF SEGMENT. 2094C 2095 IF (IGND.LT.1) GO TO 5 2096 IF (ZI1.GT.-SLEN) GO TO 4 2097 WRITE(3,56) I 2098 STOP 20994 IF (ZI1.GT.SLEN) GO TO 5 2100 ICON1(I)=I 2101 Z(I)=0. 2102 GO TO 9 21035 IC=I 2104 DO 7 J=2,N 2105 IC=IC+1 2106 IF (IC.GT.N) IC=1 2107 SEP=ABS(XI1-X(IC))+ABS(YI1-Y(IC))+ABS(ZI1-Z(IC)) 2108 IF (SEP.GT.SLEN) GO TO 6 2109 ICON1(I)=-IC 2110 GO TO 8 21116 SEP=ABS(XI1-X2(IC))+ABS(YI1-Y2(IC))+ABS(ZI1-Z2(IC)) 2112 IF (SEP.GT.SLEN) GO TO 7 2113 ICON1(I)=IC 2114 GO TO 8 21157 CONTINUE 2116 IF (I.LT.N2.AND.ICON1(I).GT.10000) GO TO 8 2117 ICON1(I)=0 2118C 2119C DETERMINE CONNECTION DATA FOR END 2 OF SEGMENT. 2120C 21218 IF (IGND.LT.1) GO TO 12 21229 IF (ZI2.GT.-SLEN) GO TO 10 2123 WRITE(3,56) I 2124 STOP 212510 IF (ZI2.GT.SLEN) GO TO 12 2126 IF (ICON1(I).NE.I) GO TO 11 2127 WRITE(3,57) I 2128 STOP 212911 ICON2(I)=I 2130 Z2(I)=0. 2131 GO TO 15 213212 IC=I 2133 DO 14 J=2,N 2134 IC=IC+1 2135 IF (IC.GT.N) IC=1 2136 SEP=ABS(XI2-X(IC))+ABS(YI2-Y(IC))+ABS(ZI2-Z(IC)) 2137 IF (SEP.GT.SLEN) GO TO 13 2138 ICON2(I)=IC 2139 GO TO 15 214013 SEP=ABS(XI2-X2(IC))+ABS(YI2-Y2(IC))+ABS(ZI2-Z2(IC)) 2141 IF (SEP.GT.SLEN) GO TO 14 2142 ICON2(I)=-IC 2143 GO TO 15 214414 CONTINUE 2145 IF (I.LT.N2.AND.ICON2(I).GT.10000) GO TO 15 2146 ICON2(I)=0 214715 CONTINUE 2148 IF (M.EQ.0) GO TO 26 2149C FIND WIRE-SURFACE CONNECTIONS FOR NEW PATCHES 2150 IX=LD+1-M1 2151 I=M2 215216 IF (I.GT.M) GO TO 20 2153 IX=IX-1 2154 XS=X(IX) 2155 YS=Y(IX) 2156 ZS=Z(IX) 2157 DO 18 ISEG=1,N 2158 XI1=X(ISEG) 2159 YI1=Y(ISEG) 2160 ZI1=Z(ISEG) 2161 XI2=X2(ISEG) 2162 YI2=Y2(ISEG) 2163 ZI2=Z2(ISEG) 2164 SLEN=(ABS(XI2-XI1)+ABS(YI2-YI1)+ABS(ZI2-ZI1))*SMIN 2165C FOR FIRST END OF SEGMENT 2166 SEP=ABS(XI1-XS)+ABS(YI1-YS)+ABS(ZI1-ZS) 2167 IF (SEP.GT.SLEN) GO TO 17 2168C CONNECTION - DIVIDE PATCH INTO 4 PATCHES AT PRESENT ARRAY LOC. 2169 ICON1(ISEG)=10000+I 2170 IC=0 2171 CALL SUBPH (I,IC,XI1,YI1,ZI1,XI2,YI2,ZI2,XA,YA,ZA,XS,YS,ZS) 2172 GO TO 19 217317 SEP=ABS(XI2-XS)+ABS(YI2-YS)+ABS(ZI2-ZS) 2174 IF (SEP.GT.SLEN) GO TO 18 2175 ICON2(ISEG)=10000+I 2176 IC=0 2177 CALL SUBPH (I,IC,XI1,YI1,ZI1,XI2,YI2,ZI2,XA,YA,ZA,XS,YS,ZS) 2178 GO TO 19 217918 CONTINUE 218019 I=I+1 2181 GO TO 16 2182C REPEAT SEARCH FOR NEW SEGMENTS CONNECTED TO NGF PATCHES. 218320 IF (M1.EQ.0.OR.N2.GT.N) GO TO 26 2184 IX=LD+1 2185 I=1 218621 IF (I.GT.M1) GO TO 25 2187 IX=IX-1 2188 XS=X(IX) 2189 YS=Y(IX) 2190 ZS=Z(IX) 2191 DO 23 ISEG=N2,N 2192 XI1=X(ISEG) 2193 YI1=Y(ISEG) 2194 ZI1=Z(ISEG) 2195 XI2=X2(ISEG) 2196 YI2=Y2(ISEG) 2197 ZI2=Z2(ISEG) 2198 SLEN=(ABS(XI2-XI1)+ABS(YI2-YI1)+ABS(ZI2-ZI1))*SMIN 2199 SEP=ABS(XI1-XS)+ABS(YI1-YS)+ABS(ZI1-ZS) 2200 IF (SEP.GT.SLEN) GO TO 22 2201 ICON1(ISEG)=10001+M 2202 IC=1 2203 NPCON=NPCON+1 2204 IPCON(NPCON)=I 2205 CALL SUBPH (I,IC,XI1,YI1,ZI1,XI2,YI2,ZI2,XA,YA,ZA,XS,YS,ZS) 2206 GO TO 24 220722 SEP=ABS(XI2-XS)+ABS(YI2-YS)+ABS(ZI2-ZS) 2208 IF (SEP.GT.SLEN) GO TO 23 2209 ICON2(ISEG)=10001+M 2210 IC=1 2211 NPCON=NPCON+1 2212 IPCON(NPCON)=I 2213 CALL SUBPH (I,IC,XI1,YI1,ZI1,XI2,YI2,ZI2,XA,YA,ZA,XS,YS,ZS) 2214 GO TO 24 221523 CONTINUE 221624 I=I+1 2217 GO TO 21 221825 IF (NPCON.LE.NPMAX) GO TO 26 2219 WRITE(3,62) NPMAX 2220 STOP 222126 WRITE(3,58) N,NP,IPSYM 2222 IF (M.GT.0) WRITE(3,61) M,MP 2223 ISEG=(N+M)/(NP+MP) 2224 IF (ISEG.EQ.1) GO TO 30 2225 IF (IPSYM) 28,27,29 222627 STOP 222728 WRITE(3,59) ISEG 2228 GO TO 30 222929 IC=ISEG/2 2230 IF (ISEG.EQ.8) IC=3 2231 WRITE(3,60) IC 223230 IF (N.EQ.0) GO TO 48 2233 WRITE(3,50) 2234 ISEG=0 2235C ADJUST CONNECTED SEG. ENDS TO EXACTLY COINCIDE. PRINT JUNCTIONS 2236C OF 3 OR MORE SEG. ALSO FIND OLD SEG. CONNECTING TO NEW SEG. 2237 DO 44 J=1,N 2238 IEND=-1 2239 JEND=-1 2240 IX=ICON1(J) 2241 IC=1 2242 JCO(1)=-J 2243 XA=X(J) 2244 YA=Y(J) 2245 ZA=Z(J) 224631 IF (IX.EQ.0) GO TO 43 2247 IF (IX.EQ.J) GO TO 43 2248 IF (IX.GT.10000) GO TO 43 2249 NSFLG=0 225032 IF (IX) 33,49,34 225133 IX=-IX 2252 GO TO 35 225334 JEND=-JEND 225435 IF (IX.EQ.J) GO TO 37 2255 IF (IX.LT.J) GO TO 43 2256 IC=IC+1 2257 IF (IC.GT.JMAX) GO TO 49 2258 JCO(IC)=IX*JEND 2259 IF (IX.GT.N1) NSFLG=1 2260 IF (JEND.EQ.1) GO TO 36 2261 XA=XA+X(IX) 2262 YA=YA+Y(IX) 2263 ZA=ZA+Z(IX) 2264 IX=ICON1(IX) 2265 GO TO 32 226636 XA=XA+X2(IX) 2267 YA=YA+Y2(IX) 2268 ZA=ZA+Z2(IX) 2269 IX=ICON2(IX) 2270 GO TO 32 227137 SEP=IC 2272 XA=XA/SEP 2273 YA=YA/SEP 2274 ZA=ZA/SEP 2275 DO 39 I=1,IC 2276 IX=JCO(I) 2277 IF (IX.GT.0) GO TO 38 2278 IX=-IX 2279 X(IX)=XA 2280 Y(IX)=YA 2281 Z(IX)=ZA 2282 GO TO 39 228338 X2(IX)=XA 2284 Y2(IX)=YA 2285 Z2(IX)=ZA 228639 CONTINUE 2287 IF (N1.EQ.0) GO TO 42 2288 IF (NSFLG.EQ.0) GO TO 42 2289 DO 41 I=1,IC 2290 IX=IABS(JCO(I)) 2291 IF (IX.GT.N1) GO TO 41 2292 IF (ICONX(IX).NE.0) GO TO 41 2293 NSCON=NSCON+1 2294 IF (NSCON.LE.NSMAX) GO TO 40 2295 WRITE(3,62) NSMAX 2296 STOP 229740 ISCON(NSCON)=IX 2298 ICONX(IX)=NSCON 229941 CONTINUE 230042 IF (IC.LT.3) GO TO 43 2301 ISEG=ISEG+1 2302 WRITE(3,51) ISEG,(JCO(I),I=1,IC) 230343 IF (IEND.EQ.1) GO TO 44 2304 IEND=1 2305 JEND=1 2306 IX=ICON2(J) 2307 IC=1 2308 JCO(1)=J 2309 XA=X2(J) 2310 YA=Y2(J) 2311 ZA=Z2(J) 2312 GO TO 31 231344 CONTINUE 2314 IF (ISEG.EQ.0) WRITE(3,52) 2315 IF (N1.EQ.0.OR.M1.EQ.M) GO TO 48 2316C FIND OLD SEGMENTS THAT CONNECT TO NEW PATCHES 2317 DO 47 J=1,N1 2318 IX=ICON1(J) 2319 IF (IX.LT.10000) GO TO 45 2320 IX=IX-10000 2321 IF (IX.GT.M1) GO TO 46 232245 IX=ICON2(J) 2323 IF (IX.LT.10000) GO TO 47 2324 IX=IX-10000 2325 IF (IX.LT.M2) GO TO 47 232646 IF (ICONX(J).NE.0) GO TO 47 2327 NSCON=NSCON+1 2328 ISCON(NSCON)=J 2329 ICONX(J)=NSCON 233047 CONTINUE 233148 CONTINUE 2332 RETURN 233349 WRITE(3,53) IX 2334 STOP 2335C 233650 FORMAT (//,9X,27H- MULTIPLE WIRE JUNCTIONS -,/,1X,8HJUNCTION,4X,36 2337 1HSEGMENTS (- FOR END 1, + FOR END 2)) 233851 FORMAT (1X,I5,5X,20I5,/,(11X,20I5)) 233952 FORMAT (2X,4HNONE) 234053 FORMAT (47H CONNECT - SEGMENT CONNECTION ERROR FOR SEGMENT,I5) 234154 FORMAT (/,3X,23HGROUND PLANE SPECIFIED.) 234255 FORMAT (/,3X,46HWHERE WIRE ENDS TOUCH GROUND, CURRENT WILL BE ,38H 2343 1INTERPOLATED TO IMAGE IN GROUND PLANE.,/) 234456 FORMAT (30H GEOMETRY DATA ERROR-- SEGMENT,I5,21H EXTENDS BELOW GRO 2345 1UND) 234657 FORMAT (29H GEOMETRY DATA ERROR--SEGMENT,I5,16H LIES IN GROUND ,6H 2347 1PLANE.) 234858 FORMAT (/,3X,20HTOTAL SEGMENTS USED=,I5,5X,12HNO. SEG. IN ,17HA SY 2349 1MMETRIC CELL=,I5,5X,14HSYMMETRY FLAG=,I3) 235059 FORMAT (14H STRUCTURE HAS,I4,25H FOLD ROTATIONAL SYMMETRY,/) 235160 FORMAT (14H STRUCTURE HAS,I2,19H PLANES OF SYMMETRY,/) 235261 FORMAT (3X,19HTOTAL PATCHES USED=,I5,6X,32HNO. PATCHES IN A SYMMET 2353 1RIC CELL=,I5) 235462 FORMAT (' ERROR - NO. NEW SEGMENTS CONNECTED TO N.G.F. SEGMENTS ', 2355 &'OR PATCHES EXCEEDS LIMIT OF',I5) 2356 END 2357 SUBROUTINE COUPLE (CUR,WLAM) 2358C *** 2359C DOUBLE PRECISION 6/4/85 2360C 2361 IMPLICIT REAL*8(A-H,O-Z) 2362C *** 2363C 2364C COUPLE COMPUTES THE MAXIMUM COUPLING BETWEEN PAIRS OF SEGMENTS. 2365C 2366 COMPLEX*16 Y11A,Y12A,CUR,Y11,Y12,Y22,YL,YIN,ZL,ZIN,RHO,VQD,VSANT 2367 1,VQDS 2368 COMMON/YPARM/Y11A(5),Y12A(20),NCOUP,ICOUP,NCTAG(5),NCSEG(5) 2369 COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS( 2370 130),NVQD,NSANT,NQDS 2371 DIMENSION CUR(1) 2372 IF (NSANT.NE.1.OR.NVQD.NE.0) RETURN 2373 J=ISEGNO(NCTAG(ICOUP+1),NCSEG(ICOUP+1)) 2374 IF (J.NE.ISANT(1)) RETURN 2375 ICOUP=ICOUP+1 2376 ZIN=VSANT(1) 2377 Y11A(ICOUP)=CUR(J)*WLAM/ZIN 2378 L1=(ICOUP-1)*(NCOUP-1) 2379 DO 1 I=1,NCOUP 2380 IF (I.EQ.ICOUP) GO TO 1 2381 K=ISEGNO(NCTAG(I),NCSEG(I)) 2382 L1=L1+1 2383 Y12A(L1)=CUR(K)*WLAM/ZIN 23841 CONTINUE 2385 IF (ICOUP.LT.NCOUP) RETURN 2386 WRITE(3,6) 2387 NPM1=NCOUP-1 2388 DO 5 I=1,NPM1 2389 ITT1=NCTAG(I) 2390 ITS1=NCSEG(I) 2391 ISG1=ISEGNO(ITT1,ITS1) 2392 L1=I+1 2393 DO 5 J=L1,NCOUP 2394 ITT2=NCTAG(J) 2395 ITS2=NCSEG(J) 2396 ISG2=ISEGNO(ITT2,ITS2) 2397 J1=J+(I-1)*NPM1-1 2398 J2=I+(J-1)*NPM1 2399 Y11=Y11A(I) 2400 Y22=Y11A(J) 2401 Y12=.5*(Y12A(J1)+Y12A(J2)) 2402 YIN=Y12*Y12 2403 DBC=ABS(YIN) 2404 C=DBC/(2.*DREAL(Y11)*DREAL(Y22)-DREAL(YIN)) 2405 IF (C.LT.0..OR.C.GT.1.) GO TO 4 2406 IF (C.LT..01) GO TO 2 2407 GMAX=(1.-SQRT(1.-C*C))/C 2408 GO TO 3 24092 GMAX=.5*(C+.25*C*C*C) 24103 RHO=GMAX*DCONJG(YIN)/DBC 2411 YL=((1.-RHO)/(1.+RHO)+1.)*DREAL(Y22)-Y22 2412 ZL=1./YL 2413 YIN=Y11-YIN/(Y22+YL) 2414 ZIN=1./YIN 2415 DBC=DB10(GMAX) 2416 WRITE(3,7) ITT1,ITS1,ISG1,ITT2,ITS2,ISG2,DBC,ZL,ZIN 2417 GO TO 5 24184 WRITE(3,8) ITT1,ITS1,ISG1,ITT2,ITS2,ISG2,C 24195 CONTINUE 2420 RETURN 2421C 24226 FORMAT (///,36X,26H- - - ISOLATION DATA - - -,//,6X,24H- - COUPLIN 2423 1G BETWEEN - -,8X,7HMAXIMUM,15X,32H- - - FOR MAXIMUM COUPLING - - - 2424 2,/,12X,4HSEG.,14X,4HSEG.,3X,8HCOUPLING,4X,25HLOAD IMPEDANCE (2ND S 2425 3EG.),7X,15HINPUT IMPEDANCE,/,2X,8HTAG/SEG.,3X,3HNO.,4X,8HTAG/SEG., 2426 43X,3HNO.,6X,4H(DB),8X,4HREAL,9X,5HIMAG.,9X,4HREAL,9X,5HIMAG.) 24277 FORMAT (2(1X,I4,1X,I4,1X,I5,2X),F9.3,2X,1P,2(2X,E12.5,1X,E12.5)) 24288 FORMAT (2(1X,I4,1X,I4,1X,I5,2X),45H**ERROR** COUPLING IS NOT BETWE 2429 1EN 0 AND 1. (=,1P,E12.5,1H)) 2430 END 2431 SUBROUTINE DATAGN 2432C *** 2433C DOUBLE PRECISION 6/4/85 2434C 2435 PARAMETER (MAXSEG=1500, MAXMAT=1500) 2436 IMPLICIT REAL*8(A-H,O-Z) 2437C *** 2438C 2439C DATAGN IS THE MAIN ROUTINE FOR INPUT OF GEOMETRY DATA. 2440C 2441C*** 2442 CHARACTER*2 GM,ATST 2443C*** 2444 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 2445 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 2446 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 2447 COMMON /ANGL/ SALP(MAXSEG) 2448C*** 2449 COMMON /PLOT/ IPLP1,IPLP2,IPLP3,IPLP4 2450C*** 2451 DIMENSION X2(1), Y2(1), Z2(1), T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y 2452 1(1), T2Z(1), ATST(13), IFX(2), IFY(2), IFZ(2), CAB(1), SAB(1), IPT 2453 2(4) 2454 EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON 2455 12), (T2Z,ITAG), (X2,SI), (Y2,ALP), (Z2,BET), (CAB,ALP), (SAB,BET) 2456C*** 2457 DATA ATST/'GW','GX','GR','GS','GE','GM','SP','SM','GF','GA','SC', 2458 1'GC','GH'/ 2459C*** 2460 DATA IFX/1H ,1HX/,IFY/1H ,1HY/,IFZ/1H ,1HZ/ 2461 DATA TA/0.01745329252D+0/,TD/57.29577951D+0/,IPT/1HP,1HR,1HT,1HQ/ 2462 IPSYM=0 2463 NWIRE=0 2464 N=0 2465 NP=0 2466 M=0 2467 MP=0 2468 N1=0 2469 N2=1 2470 M1=0 2471 M2=1 2472 ISCT=0 2473 IPHD=0 2474C 2475C READ GEOMETRY DATA CARD AND BRANCH TO SECTION FOR OPERATION 2476C REQUESTED 2477C 24781 CALL READGM(2,GM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD) 2479 IF (N+M.GT.LD) GO TO 37 2480 IF (GM.EQ.ATST(9)) GO TO 27 2481 IF (IPHD.EQ.1) GO TO 2 2482 WRITE(3,40) 2483 WRITE(3,41) 2484 IPHD=1 24852 IF (GM.EQ.ATST(11)) GO TO 10 2486 ISCT=0 2487 IF (GM.EQ.ATST(1)) GO TO 3 2488 IF (GM.EQ.ATST(2)) GO TO 18 2489 IF (GM.EQ.ATST(3)) GO TO 19 2490 IF (GM.EQ.ATST(4)) GO TO 21 2491 IF (GM.EQ.ATST(7)) GO TO 9 2492 IF (GM.EQ.ATST(8)) GO TO 13 2493 IF (GM.EQ.ATST(5)) GO TO 29 2494 IF (GM.EQ.ATST(6)) GO TO 26 2495 IF (GM.EQ.ATST(10)) GO TO 8 2496C*** 2497 IF (GM.EQ.ATST(13)) GO TO 123 2498C*** 2499 GO TO 36 2500C 2501C GENERATE SEGMENT DATA FOR STRAIGHT WIRE. 2502C 25033 NWIRE=NWIRE+1 2504 I1=N+1 2505 I2=N+NS 2506 WRITE(3,43) NWIRE,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,NS,I1,I2,ITG 2507 IF (RAD.EQ.0) GO TO 4 2508 XS1=1. 2509 YS1=1. 2510 GO TO 7 25114 CALL READGM(2,GM,IX,IY,XS1,YS1,ZS1,DUMMY,DUMMY,DUMMY,DUMMY) 2512C*** 2513 IF (GM.EQ.ATST(12)) GO TO 6 25145 WRITE(3,48) 2515 STOP 25166 WRITE(3,61) XS1,YS1,ZS1 2517 IF (YS1.EQ.0.OR.ZS1.EQ.0) GO TO 5 2518 RAD=YS1 2519 YS1=(ZS1/YS1)**(1./(NS-1.)) 25207 CALL WIRE (XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,XS1,YS1,NS,ITG) 2521 GO TO 1 2522C 2523C GENERATE SEGMENT DATA FOR WIRE ARC 2524C 25258 NWIRE=NWIRE+1 2526 I1=N+1 2527 I2=N+NS 2528 WRITE(3,38) NWIRE,XW1,YW1,ZW1,XW2,NS,I1,I2,ITG 2529 CALL ARC (ITG,NS,XW1,YW1,ZW1,XW2) 2530 GO TO 1 2531C*** 2532C 2533C GENERATE HELIX 2534C 2535123 NWIRE=NWIRE+1 2536 I1=N+1 2537 I2=N+NS 2538 WRITE(3,124) XW1,YW1,NWIRE,ZW1,XW2,YW2,ZW2,RAD,NS,I1,I2,ITG 2539 CALL HELIX(XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,NS,ITG) 2540 GO TO 1 2541C 2542124 FORMAT(5X,'HELIX STRUCTURE- AXIAL SPACING BETWEEN TURNS =',F8.3, 2543 1' TOTAL AXIAL LENGTH =',F8.3/1X,I5,2X,'RADIUS OF HELIX =',4(2X, 2544 2F8.3),7X,F11.5,I8,4X,I5,1X,I5,3X,I5) 2545C*** 2546C 2547C GENERATE SINGLE NEW PATCH 2548C 25499 I1=M+1 2550 NS=NS+1 2551 IF (ITG.NE.0) GO TO 17 2552 WRITE(3,51) I1,IPT(NS),XW1,YW1,ZW1,XW2,YW2,ZW2 2553 IF (NS.EQ.2.OR.NS.EQ.4) ISCT=1 2554 IF (NS.GT.1) GO TO 14 2555 XW2=XW2*TA 2556 YW2=YW2*TA 2557 GO TO 16 255810 IF (ISCT.EQ.0) GO TO 17 2559 I1=M+1 2560 NS=NS+1 2561 IF (ITG.NE.0) GO TO 17 2562 IF (NS.NE.2.AND.NS.NE.4) GO TO 17 2563 XS1=X4 2564 YS1=Y4 2565 ZS1=Z4 2566 XS2=X3 2567 YS2=Y3 2568 ZS2=Z3 2569 X3=XW1 2570 Y3=YW1 2571 Z3=ZW1 2572 IF (NS.NE.4) GO TO 11 2573 X4=XW2 2574 Y4=YW2 2575 Z4=ZW2 257611 XW1=XS1 2577 YW1=YS1 2578 ZW1=ZS1 2579 XW2=XS2 2580 YW2=YS2 2581 ZW2=ZS2 2582 IF (NS.EQ.4) GO TO 12 2583 X4=XW1+X3-XW2 2584 Y4=YW1+Y3-YW2 2585 Z4=ZW1+Z3-ZW2 258612 WRITE(3,51) I1,IPT(NS),XW1,YW1,ZW1,XW2,YW2,ZW2 2587 WRITE(3,39) X3,Y3,Z3,X4,Y4,Z4 2588 GO TO 16 2589C 2590C GENERATE MULTIPLE-PATCH SURFACE 2591C 259213 I1=M+1 2593 WRITE(3,59) I1,IPT(2),XW1,YW1,ZW1,XW2,YW2,ZW2,ITG,NS 2594 IF (ITG.LT.1.OR.NS.LT.1) GO TO 17 259514 CALL READGM(2,GM,IX,IY,X3,Y3,Z3,X4,Y4,Z4,DUMMY) 2596 IF (NS.NE.2.AND.ITG.LT.1) GO TO 15 2597 X4=XW1+X3-XW2 2598 Y4=YW1+Y3-YW2 2599 Z4=ZW1+Z3-ZW2 260015 WRITE(3,39) X3,Y3,Z3,X4,Y4,Z4 2601 IF (GM.NE.ATST(11)) GO TO 17 260216 CALL PATCH (ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,X3,Y3,Z3,X4,Y4,Z4) 2603 GO TO 1 260417 WRITE(3,60) 2605 STOP 2606C 2607C REFLECT STRUCTURE ALONG X,Y, OR Z AXES OR ROTATE TO FORM CYLINDER. 2608C 260918 IY=NS/10 2610 IZ=NS-IY*10 2611 IX=IY/10 2612 IY=IY-IX*10 2613 IF (IX.NE.0) IX=1 2614 IF (IY.NE.0) IY=1 2615 IF (IZ.NE.0) IZ=1 2616 WRITE(3,44) IFX(IX+1),IFY(IY+1),IFZ(IZ+1),ITG 2617 GO TO 20 261819 WRITE(3,45) NS,ITG 2619 IX=-1 262020 CALL REFLC (IX,IY,IZ,ITG,NS) 2621 GO TO 1 2622C 2623C SCALE STRUCTURE DIMENSIONS BY FACTOR XW1. 2624C 262521 IF (N.LT.N2) GO TO 23 2626 DO 22 I=N2,N 2627 X(I)=X(I)*XW1 2628 Y(I)=Y(I)*XW1 2629 Z(I)=Z(I)*XW1 2630 X2(I)=X2(I)*XW1 2631 Y2(I)=Y2(I)*XW1 2632 Z2(I)=Z2(I)*XW1 263322 BI(I)=BI(I)*XW1 263423 IF (M.LT.M2) GO TO 25 2635 YW1=XW1*XW1 2636 IX=LD+1-M 2637 IY=LD-M1 2638 DO 24 I=IX,IY 2639 X(I)=X(I)*XW1 2640 Y(I)=Y(I)*XW1 2641 Z(I)=Z(I)*XW1 264224 BI(I)=BI(I)*YW1 264325 WRITE(3,46) XW1 2644 GO TO 1 2645C 2646C MOVE STRUCTURE OR REPRODUCE ORIGINAL STRUCTURE IN NEW POSITIONS. 2647C 264826 WRITE(3,47) ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD 2649 XW1=XW1*TA 2650 YW1=YW1*TA 2651 ZW1=ZW1*TA 2652 CALL MOVE (XW1,YW1,ZW1,XW2,YW2,ZW2,INT(RAD+.5),NS,ITG) 2653 GO TO 1 2654C 2655C READ NUMERICAL GREEN'S FUNCTION TAPE 2656C 265727 IF (N+M.EQ.0) GO TO 28 2658 WRITE(3,52) 2659 STOP 266028 CALL GFIL (ITG) 2661 NPSAV=NP 2662 MPSAV=MP 2663 IPSAV=IPSYM 2664 GO TO 1 2665C 2666C TERMINATE STRUCTURE GEOMETRY INPUT. 2667C 2668C*** 266929 IF(NS.EQ.0) GO TO 290 2670 IPLP1=1 2671 IPLP2=1 2672290 IX=N1+M1 2673C*** 2674 IF (IX.EQ.0) GO TO 30 2675 NP=N 2676 MP=M 2677 IPSYM=0 267830 CALL CONECT (ITG) 2679 IF (IX.EQ.0) GO TO 31 2680 NP=NPSAV 2681 MP=MPSAV 2682 IPSYM=IPSAV 268331 IF (N+M.GT.LD) GO TO 37 2684 IF (N.EQ.0) GO TO 33 2685 WRITE(3,53) 2686 WRITE(3,54) 2687 DO 32 I=1,N 2688 XW1=X2(I)-X(I) 2689 YW1=Y2(I)-Y(I) 2690 ZW1=Z2(I)-Z(I) 2691 X(I)=(X(I)+X2(I))*.5 2692 Y(I)=(Y(I)+Y2(I))*.5 2693 Z(I)=(Z(I)+Z2(I))*.5 2694 XW2=XW1*XW1+YW1*YW1+ZW1*ZW1 2695 YW2=SQRT(XW2) 2696 YW2=(XW2/YW2+YW2)*.5 2697 SI(I)=YW2 2698 CAB(I)=XW1/YW2 2699 SAB(I)=YW1/YW2 2700 XW2=ZW1/YW2 2701 IF (XW2.GT.1.) XW2=1. 2702 IF (XW2.LT.-1.) XW2=-1. 2703 SALP(I)=XW2 2704 XW2=ASIN(XW2)*TD 2705 YW2=ATGN2(YW1,XW1)*TD 2706 WRITE(3,55) I,X(I),Y(I),Z(I),SI(I),XW2,YW2,BI(I),ICON1(I),I, 2707 1ICON2(I),ITAG(I) 2708C*** 2709 IF(IPLP1.NE.1) GO TO 320 2710 WRITE(8,*)X(I),Y(I),Z(I),SI(I),XW2,YW2,BI(I),ICON1(I),I,ICON2(I) 2711320 CONTINUE 2712C*** 2713 IF (SI(I).GT.1.D-20.AND.BI(I).GT.0.) GO TO 32 2714 WRITE(3,56) 2715 STOP 271632 CONTINUE 271733 IF (M.EQ.0) GO TO 35 2718 WRITE(3,57) 2719 J=LD+1 2720 DO 34 I=1,M 2721 J=J-1 2722 XW1=(T1Y(J)*T2Z(J)-T1Z(J)*T2Y(J))*SALP(J) 2723 YW1=(T1Z(J)*T2X(J)-T1X(J)*T2Z(J))*SALP(J) 2724 ZW1=(T1X(J)*T2Y(J)-T1Y(J)*T2X(J))*SALP(J) 2725 WRITE(3,58) I,X(J),Y(J),Z(J),XW1,YW1,ZW1,BI(J),T1X(J),T1Y(J), 2726 1T1Z(J),T2X(J),T2Y(J),T2Z(J) 272734 CONTINUE 272835 RETURN 272936 WRITE(3,48) 2730 WRITE(3,49) GM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD 2731 STOP 273237 WRITE(3,50) 2733 STOP 2734C 273538 FORMAT (1X,I5,2X,12HARC RADIUS =,F9.5,2X,4HFROM,F8.3,3H TO,F8.3,8H 2736 1 DEGREES,11X,F11.5,2X,I5,4X,I5,1X,I5,3X,I5) 273739 FORMAT (6X,3F11.5,1X,3F11.5) 273840 FORMAT (////,33X,35H- - - STRUCTURE SPECIFICATION - - -,//,37X,28H 2739 1COORDINATES MUST BE INPUT IN,/,37X,29HMETERS OR BE SCALED TO METER 2740 2S,/,37X,31HBEFORE STRUCTURE INPUT IS ENDED,//) 274141 FORMAT (2X,4HWIRE,79X,6HNO. OF,4X,5HFIRST,2X,4HLAST,5X,3HTAG,/,2X, 2742 13HNO.,8X,2HX1,9X,2HY1,9X,2HZ1,10X,2HX2,9X,2HY2,9X,2HZ2,6X,6HRADIUS 2743 2,3X,4HSEG.,5X,4HSEG.,3X,4HSEG.,5X,3HNO.) 274442 FORMAT (A2,I3,I5,7F10.5) 274543 FORMAT (1X,I5,3F11.5,1X,4F11.5,2X,I5,4X,I5,1X,I5,3X,I5) 274644 FORMAT (6X,34HSTRUCTURE REFLECTED ALONG THE AXES,3(1X,A1),22H. TA 2747 1GS INCREMENTED BY,I5) 274845 FORMAT (6X,30HSTRUCTURE ROTATED ABOUT Z-AXIS,I3,30H TIMES. LABELS 2749 1 INCREMENTED BY,I5) 275046 FORMAT (6X,26HSTRUCTURE SCALED BY FACTOR,F10.5) 275147 FORMAT (6X,49HTHE STRUCTURE HAS BEEN MOVED, MOVE DATA CARD IS -/6X 2752 1,I3,I5,7F10.5) 275348 FORMAT (25H GEOMETRY DATA CARD ERROR) 275449 FORMAT (1X,A2,I3,I5,7F10.5) 275550 FORMAT (69H NUMBER OF WIRE SEGMENTS AND SURFACE PATCHES EXCEEDS DI 2756 1MENSION LIMIT.) 275751 FORMAT (1X,I5,A1,F10.5,2F11.5,1X,3F11.5) 275852 FORMAT (44H ERROR - GF MUST BE FIRST GEOMETRY DATA CARD) 275953 FORMAT (////33X,33H- - - - SEGMENTATION DATA - - - -,//,40X,21HCOO 2760 1RDINATES IN METERS,//,25X,50HI+ AND I- INDICATE THE SEGMENTS BEFOR 2761 2E AND AFTER I,//) 276254 FORMAT (2X,4HSEG.,3X,26HCOORDINATES OF SEG. CENTER,5X,4HSEG.,5X,18 2763 1HORIENTATION ANGLES,4X,4HWIRE,4X,15HCONNECTION DATA,3X,3HTAG,/,2X, 2764 23HNO.,7X,1HX,9X,1HY,9X,1HZ,7X,6HLENGTH,5X,5HALPHA,5X,4HBETA,6X,6HR 2765 3ADIUS,4X,2HI-,3X,1HI,4X,2HI+,4X,3HNO.) 276655 FORMAT (1X,I5,4F10.5,1X,3F10.5,1X,3I5,2X,I5) 276756 FORMAT (19H SEGMENT DATA ERROR) 276857 FORMAT (////,44X,30H- - - SURFACE PATCH DATA - - -,//,49X,21HCOORD 2769 1INATES IN METERS,//,1X,5HPATCH,5X,22HCOORD. OF PATCH CENTER,7X,18H 2770 2UNIT NORMAL VECTOR,6X,5HPATCH,12X,34HCOMPONENTS OF UNIT TANGENT VE 2771 3CTORS,/,2X,3HNO.,6X,1HX,9X,1HY,9X,1HZ,9X,1HX,7X,1HY,7X,1HZ,7X,4HAR 2772 4EA,7X,2HX1,6X,2HY1,6X,2HZ1,7X,2HX2,6X,2HY2,6X,2HZ2) 277358 FORMAT (1X,I4,3F10.5,1X,3F8.4,F10.5,1X,3F8.4,1X,3F8.4) 277459 FORMAT (1X,I5,A1,F10.5,2F11.5,1X,3F11.5,5X,9HSURFACE -,I4,3H BY,I3 2775 1,8H PATCHES) 277660 FORMAT (17H PATCH DATA ERROR) 277761 FORMAT (9X,43HABOVE WIRE IS TAPERED. SEG. LENGTH RATIO =,F9.5,/,3 2778 13X,11HRADIUS FROM,F9.5,3H TO,F9.5) 2779 END 2780 FUNCTION DB10 (X) 2781C *** 2782C DOUBLE PRECISION 6/4/85 2783C 2784 IMPLICIT REAL*8(A-H,O-Z) 2785C *** 2786C 2787C FUNCTION DB-- RETURNS DB FOR MAGNITUDE (FIELD) OR MAG**2 (POWER) I 2788C 2789 F=10. 2790 GO TO 1 2791 ENTRY DB20(X) 2792 F=20. 27931 IF (X.LT.1.D-20) GO TO 2 2794 DB10=F*LOG10(X) 2795 RETURN 27962 DB10=-999.99 2797 RETURN 2798 END 2799 SUBROUTINE EFLD (XI,YI,ZI,AI,IJ) 2800C *** 2801C DOUBLE PRECISION 6/4/85 2802C 2803 IMPLICIT REAL*8(A-H,O-Z) 2804C *** 2805C 2806C COMPUTE NEAR E FIELDS OF A SEGMENT WITH SINE, COSINE, AND 2807C CONSTANT CURRENTS. GROUND EFFECT INCLUDED. 2808C 2809 COMPLEX*16 TXK,TYK,TZK,TXS,TYS,TZS,TXC,TYC,TZC,EXK,EYK,EZK,EXS,EYS 2810 1,EZS,EXC,EYC,EZC,EPX,EPY,ZRATI,REFS,REFPS,ZRSIN,ZRATX,T1,ZSCRN 2811 2,ZRATI2,TEZS,TERS,TEZC,TERC,TEZK,TERK,EGND,FRATI 2812 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 2813 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 2814 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 2815 &KSYMP,IFAR,IPERF 2816 COMMON /INCOM/ XO,YO,ZO,SN,XSN,YSN,ISNOR 2817 DIMENSION EGND(9) 2818 EQUIVALENCE (EGND(1),TXK), (EGND(2),TYK), (EGND(3),TZK), (EGND(4), 2819 1TXS), (EGND(5),TYS), (EGND(6),TZS), (EGND(7),TXC), (EGND(8),TYC), 2820 2(EGND(9),TZC) 2821 DATA ETA/376.73/,PI/3.141592654D+0/,TP/6.283185308D+0/ 2822 XIJ=XI-XJ 2823 YIJ=YI-YJ 2824 IJX=IJ 2825 RFL=-1. 2826 DO 12 IP=1,KSYMP 2827 IF (IP.EQ.2) IJX=1 2828 RFL=-RFL 2829 SALPR=SALPJ*RFL 2830 ZIJ=ZI-RFL*ZJ 2831 ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR 2832 RHOX=XIJ-CABJ*ZP 2833 RHOY=YIJ-SABJ*ZP 2834 RHOZ=ZIJ-SALPR*ZP 2835 RH=SQRT(RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ+AI*AI) 2836 IF (RH.GT.1.D-10) GO TO 1 2837 RHOX=0. 2838 RHOY=0. 2839 RHOZ=0. 2840 GO TO 2 28411 RHOX=RHOX/RH 2842 RHOY=RHOY/RH 2843 RHOZ=RHOZ/RH 28442 R=SQRT(ZP*ZP+RH*RH) 2845 IF (R.LT.RKH) GO TO 3 2846C 2847C LUMPED CURRENT ELEMENT APPROX. FOR LARGE SEPARATIONS 2848C 2849 RMAG=TP*R 2850 CTH=ZP/R 2851 PX=RH/R 2852 TXK=DCMPLX(COS(RMAG),-SIN(RMAG)) 2853 PY=TP*R*R 2854 TYK=ETA*CTH*TXK*DCMPLX(1.D+0,-1.D+0/RMAG)/PY 2855 TZK=ETA*PX*TXK*DCMPLX(1.D+0,RMAG-1.D+0/RMAG)/(2.*PY) 2856 TEZK=TYK*CTH-TZK*PX 2857 TERK=TYK*PX+TZK*CTH 2858 RMAG=SIN(PI*S)/PI 2859 TEZC=TEZK*RMAG 2860 TERC=TERK*RMAG 2861 TEZK=TEZK*S 2862 TERK=TERK*S 2863 TXS=(0.,0.) 2864 TYS=(0.,0.) 2865 TZS=(0.,0.) 2866 GO TO 6 28673 IF (IEXK.EQ.1) GO TO 4 2868C 2869C EKSC FOR THIN WIRE APPROX. OR EKSCX FOR EXTENDED T.W. APPROX. 2870C 2871 CALL EKSC (S,ZP,RH,TP,IJX,TEZS,TERS,TEZC,TERC,TEZK,TERK) 2872 GO TO 5 28734 CALL EKSCX (B,S,ZP,RH,TP,IJX,IND1,IND2,TEZS,TERS,TEZC,TERC,TEZK,TE 2874 1RK) 28755 TXS=TEZS*CABJ+TERS*RHOX 2876 TYS=TEZS*SABJ+TERS*RHOY 2877 TZS=TEZS*SALPR+TERS*RHOZ 28786 TXK=TEZK*CABJ+TERK*RHOX 2879 TYK=TEZK*SABJ+TERK*RHOY 2880 TZK=TEZK*SALPR+TERK*RHOZ 2881 TXC=TEZC*CABJ+TERC*RHOX 2882 TYC=TEZC*SABJ+TERC*RHOY 2883 TZC=TEZC*SALPR+TERC*RHOZ 2884 IF (IP.NE.2) GO TO 11 2885 IF (IPERF.GT.0) GO TO 10 2886 ZRATX=ZRATI 2887 RMAG=R 2888 XYMAG=SQRT(XIJ*XIJ+YIJ*YIJ) 2889C 2890C SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN. 2891C 2892 IF (NRADL.EQ.0) GO TO 7 2893 XSPEC=(XI*ZJ+ZI*XJ)/(ZI+ZJ) 2894 YSPEC=(YI*ZJ+ZI*YJ)/(ZI+ZJ) 2895 RHOSPC=SQRT(XSPEC*XSPEC+YSPEC*YSPEC+T2*T2) 2896 IF (RHOSPC.GT.SCRWL) GO TO 7 2897 ZSCRN=T1*RHOSPC*LOG(RHOSPC/T2) 2898 ZRATX=(ZSCRN*ZRATI)/(ETA*ZRATI+ZSCRN) 28997 IF (XYMAG.GT.1.D-6) GO TO 8 2900C 2901C CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED. 2902C 2903 PX=0. 2904 PY=0. 2905 CTH=1. 2906 ZRSIN=(1.,0.) 2907 GO TO 9 29088 PX=-YIJ/XYMAG 2909 PY=XIJ/XYMAG 2910 CTH=ZIJ/RMAG 2911 ZRSIN=SQRT(1.-ZRATX*ZRATX*(1.-CTH*CTH)) 29129 REFS=(CTH-ZRATX*ZRSIN)/(CTH+ZRATX*ZRSIN) 2913 REFPS=-(ZRATX*CTH-ZRSIN)/(ZRATX*CTH+ZRSIN) 2914 REFPS=REFPS-REFS 2915 EPY=PX*TXK+PY*TYK 2916 EPX=PX*EPY 2917 EPY=PY*EPY 2918 TXK=REFS*TXK+REFPS*EPX 2919 TYK=REFS*TYK+REFPS*EPY 2920 TZK=REFS*TZK 2921 EPY=PX*TXS+PY*TYS 2922 EPX=PX*EPY 2923 EPY=PY*EPY 2924 TXS=REFS*TXS+REFPS*EPX 2925 TYS=REFS*TYS+REFPS*EPY 2926 TZS=REFS*TZS 2927 EPY=PX*TXC+PY*TYC 2928 EPX=PX*EPY 2929 EPY=PY*EPY 2930 TXC=REFS*TXC+REFPS*EPX 2931 TYC=REFS*TYC+REFPS*EPY 2932 TZC=REFS*TZC 293310 EXK=EXK-TXK*FRATI 2934 EYK=EYK-TYK*FRATI 2935 EZK=EZK-TZK*FRATI 2936 EXS=EXS-TXS*FRATI 2937 EYS=EYS-TYS*FRATI 2938 EZS=EZS-TZS*FRATI 2939 EXC=EXC-TXC*FRATI 2940 EYC=EYC-TYC*FRATI 2941 EZC=EZC-TZC*FRATI 2942 GO TO 12 294311 EXK=TXK 2944 EYK=TYK 2945 EZK=TZK 2946 EXS=TXS 2947 EYS=TYS 2948 EZS=TZS 2949 EXC=TXC 2950 EYC=TYC 2951 EZC=TZC 295212 CONTINUE 2953 IF (IPERF.EQ.2) GO TO 13 2954 RETURN 2955C 2956C FIELD DUE TO GROUND USING SOMMERFELD/NORTON 2957C 295813 SN=SQRT(CABJ*CABJ+SABJ*SABJ) 2959 IF (SN.LT.1.D-5) GO TO 14 2960 XSN=CABJ/SN 2961 YSN=SABJ/SN 2962 GO TO 15 296314 SN=0. 2964 XSN=1. 2965 YSN=0. 2966C 2967C DISPLACE OBSERVATION POINT FOR THIN WIRE APPROXIMATION 2968C 296915 ZIJ=ZI+ZJ 2970 SALPR=-SALPJ 2971 RHOX=SABJ*ZIJ-SALPR*YIJ 2972 RHOY=SALPR*XIJ-CABJ*ZIJ 2973 RHOZ=CABJ*YIJ-SABJ*XIJ 2974 RH=RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ 2975 IF (RH.GT.1.D-10) GO TO 16 2976 XO=XI-AI*YSN 2977 YO=YI+AI*XSN 2978 ZO=ZI 2979 GO TO 17 298016 RH=AI/SQRT(RH) 2981 IF (RHOZ.LT.0.) RH=-RH 2982 XO=XI+RH*RHOX 2983 YO=YI+RH*RHOY 2984 ZO=ZI+RH*RHOZ 298517 R=XIJ*XIJ+YIJ*YIJ+ZIJ*ZIJ 2986 IF (R.GT..95) GO TO 18 2987C 2988C FIELD FROM INTERPOLATION IS INTEGRATED OVER SEGMENT 2989C 2990 ISNOR=1 2991 DMIN=EXK*DCONJG(EXK)+EYK*DCONJG(EYK)+EZK*DCONJG(EZK) 2992 DMIN=.01*SQRT(DMIN) 2993 SHAF=.5*S 2994 CALL ROM2 (-SHAF,SHAF,EGND,DMIN) 2995 GO TO 19 2996C 2997C NORTON FIELD EQUATIONS AND LUMPED CURRENT ELEMENT APPROXIMATION 2998C 299918 ISNOR=2 3000 CALL SFLDS (0.D0,EGND) 3001 GO TO 22 300219 ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR 3003 RH=R-ZP*ZP 3004 IF (RH.GT.1.D-10) GO TO 20 3005 DMIN=0. 3006 GO TO 21 300720 DMIN=SQRT(RH/(RH+AI*AI)) 300821 IF (DMIN.GT..95) GO TO 22 3009 PX=1.-DMIN 3010 TERK=(TXK*CABJ+TYK*SABJ+TZK*SALPR)*PX 3011 TXK=DMIN*TXK+TERK*CABJ 3012 TYK=DMIN*TYK+TERK*SABJ 3013 TZK=DMIN*TZK+TERK*SALPR 3014 TERS=(TXS*CABJ+TYS*SABJ+TZS*SALPR)*PX 3015 TXS=DMIN*TXS+TERS*CABJ 3016 TYS=DMIN*TYS+TERS*SABJ 3017 TZS=DMIN*TZS+TERS*SALPR 3018 TERC=(TXC*CABJ+TYC*SABJ+TZC*SALPR)*PX 3019 TXC=DMIN*TXC+TERC*CABJ 3020 TYC=DMIN*TYC+TERC*SABJ 3021 TZC=DMIN*TZC+TERC*SALPR 302222 EXK=EXK+TXK 3023 EYK=EYK+TYK 3024 EZK=EZK+TZK 3025 EXS=EXS+TXS 3026 EYS=EYS+TYS 3027 EZS=EZS+TZS 3028 EXC=EXC+TXC 3029 EYC=EYC+TYC 3030 EZC=EZC+TZC 3031 RETURN 3032 END 3033 SUBROUTINE EKSC (S,Z,RH,XK,IJ,EZS,ERS,EZC,ERC,EZK,ERK) 3034C *** 3035C DOUBLE PRECISION 6/4/85 3036C 3037 IMPLICIT REAL*8(A-H,O-Z) 3038C *** 3039C COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY 3040C THIN WIRE APPROXIMATION. 3041 COMPLEX*16 CON,GZ1,GZ2,GP1,GP2,GZP1,GZP2,EZS,ERS,EZC,ERC,EZK,ERK 3042 COMMON /TMI/ ZPK,RKB2,IJX 3043 DIMENSION CONX(2) 3044 EQUIVALENCE (CONX,CON) 3045 DATA CONX/0.,4.771341189D+0/ 3046 IJX=IJ 3047 ZPK=XK*Z 3048 RHK=XK*RH 3049 RKB2=RHK*RHK 3050 SH=.5*S 3051 SHK=XK*SH 3052 SS=SIN(SHK) 3053 CS=COS(SHK) 3054 Z2=SH-Z 3055 Z1=-(SH+Z) 3056 CALL GX (Z1,RH,XK,GZ1,GP1) 3057 CALL GX (Z2,RH,XK,GZ2,GP2) 3058 GZP1=GP1*Z1 3059 GZP2=GP2*Z2 3060 EZS=CON*((GZ2-GZ1)*CS*XK-(GZP2+GZP1)*SS) 3061 EZC=-CON*((GZ2+GZ1)*SS*XK+(GZP2-GZP1)*CS) 3062 ERK=CON*(GP2-GP1)*RH 3063 CALL INTX (-SHK,SHK,RHK,IJ,CINT,SINT) 3064 EZK=-CON*(GZP2-GZP1+XK*XK*DCMPLX(CINT,-SINT)) 3065 GZP1=GZP1*Z1 3066 GZP2=GZP2*Z2 3067 IF (RH.LT.1.D-10) GO TO 1 3068 ERS=-CON*((GZP2+GZP1+GZ2+GZ1)*SS-(Z2*GZ2-Z1*GZ1)*CS*XK)/RH 3069 ERC=-CON*((GZP2-GZP1+GZ2-GZ1)*CS+(Z2*GZ2+Z1*GZ1)*SS*XK)/RH 3070 RETURN 30711 ERS=(0.,0.) 3072 ERC=(0.,0.) 3073 RETURN 3074 END 3075 SUBROUTINE EKSCX (BX,S,Z,RHX,XK,IJ,INX1,INX2,EZS,ERS,EZC,ERC,EZK,E 3076 1RK) 3077C *** 3078C DOUBLE PRECISION 6/4/85 3079C 3080 IMPLICIT REAL*8(A-H,O-Z) 3081C *** 3082C COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY 3083C EXTENDED THIN WIRE APPROXIMATION. 3084 COMPLEX*16 CON,GZ1,GZ2,GZP1,GZP2,GR1,GR2,GRP1,GRP2,EZS,EZC,ERS,ERC 3085 1,GRK1,GRK2,EZK,ERK,GZZ1,GZZ2 3086 COMMON /TMI/ ZPK,RKB2,IJX 3087 DIMENSION CONX(2) 3088 EQUIVALENCE (CONX,CON) 3089 DATA CONX/0.,4.771341189D+0/ 3090 IF (RHX.LT.BX) GO TO 1 3091 RH=RHX 3092 B=BX 3093 IRA=0 3094 GO TO 2 30951 RH=BX 3096 B=RHX 3097 IRA=1 30982 SH=.5*S 3099 IJX=IJ 3100 ZPK=XK*Z 3101 RHK=XK*RH 3102 RKB2=RHK*RHK 3103 SHK=XK*SH 3104 SS=SIN(SHK) 3105 CS=COS(SHK) 3106 Z2=SH-Z 3107 Z1=-(SH+Z) 3108 A2=B*B 3109 IF (INX1.EQ.2) GO TO 3 3110 CALL GXX (Z1,RH,B,A2,XK,IRA,GZ1,GZP1,GR1,GRP1,GRK1,GZZ1) 3111 GO TO 4 31123 CALL GX (Z1,RHX,XK,GZ1,GRK1) 3113 GZP1=GRK1*Z1 3114 GR1=GZ1/RHX 3115 GRP1=GZP1/RHX 3116 GRK1=GRK1*RHX 3117 GZZ1=(0.,0.) 31184 IF (INX2.EQ.2) GO TO 5 3119 CALL GXX (Z2,RH,B,A2,XK,IRA,GZ2,GZP2,GR2,GRP2,GRK2,GZZ2) 3120 GO TO 6 31215 CALL GX (Z2,RHX,XK,GZ2,GRK2) 3122 GZP2=GRK2*Z2 3123 GR2=GZ2/RHX 3124 GRP2=GZP2/RHX 3125 GRK2=GRK2*RHX 3126 GZZ2=(0.,0.) 31276 EZS=CON*((GZ2-GZ1)*CS*XK-(GZP2+GZP1)*SS) 3128 EZC=-CON*((GZ2+GZ1)*SS*XK+(GZP2-GZP1)*CS) 3129 ERS=-CON*((Z2*GRP2+Z1*GRP1+GR2+GR1)*SS-(Z2*GR2-Z1*GR1)*CS*XK) 3130 ERC=-CON*((Z2*GRP2-Z1*GRP1+GR2-GR1)*CS+(Z2*GR2+Z1*GR1)*SS*XK) 3131 ERK=CON*(GRK2-GRK1) 3132 CALL INTX (-SHK,SHK,RHK,IJ,CINT,SINT) 3133 BK=B*XK 3134 BK2=BK*BK*.25 3135 EZK=-CON*(GZP2-GZP1+XK*XK*(1.-BK2)*DCMPLX(CINT,-SINT)-BK2*(GZZ2- 3136 1GZZ1)) 3137 RETURN 3138 END 3139 SUBROUTINE ERROR 3140C *** 3141C GET REASON FOR FILE ERROR (VAX ONLY). ERROR SHOULD BE REDUCED TO 3142C "RETURN END" FOR MACINTOSH. 3143C 3144C IMPLICIT INTEGER (A-Z) 3145C CHARACTER MSG*80 3146C CALL ERRSNS(FNUM,RMSSTS,RMSSTV,IUNIT,CONDVAL) 3147C CALL SYS$GETMSG(%VAL(RMSSTS),MSGLEN,MSG,,,) 3148C CALL STR$UPCASE(MSG,MSG) 3149C IND=INDEX(MSG,',') 3150C TYPE 1,MSG(IND+2:MSGLEN) 3151C1 FORMAT(//,' **** ERROR **** ',//,5X,A,//) 3152 RETURN 3153 END 3154 SUBROUTINE ETMNS (P1,P2,P3,P4,P5,P6,IPR,E) 3155C *** 3156C DOUBLE PRECISION 6/4/85 3157C 3158 PARAMETER (MAXSEG=1500, MAXMAT=1500) 3159 IMPLICIT REAL*8(A-H,O-Z) 3160C *** 3161C 3162C ETMNS FILLS THE ARRAY E WITH THE NEGATIVE OF THE ELECTRIC FIELD 3163C INCIDENT ON THE STRUCTURE. E IS THE RIGHT HAND SIDE OF THE MATRIX 3164C EQUATION. 3165C 3166 COMPLEX*16 E,CX,CY,CZ,VSANT,ER,ET,EZH,ERH,VQD,VQDS,ZRATI 3167 1,ZRATI2,RRV,RRH,T1,TT1,TT2,FRATI 3168 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 3169 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 3170 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 3171 COMMON /ANGL/ SALP(MAXSEG) 3172 COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS( 3173 130),NVQD,NSANT,NQDS 3174 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 3175 &KSYMP,IFAR,IPERF 3176 DIMENSION CAB(1), SAB(1), E(2*MAXSEG) 3177 DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) 3178 EQUIVALENCE (CAB,ALP), (SAB,BET) 3179 EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON 3180 12), (T2Z,ITAG) 3181 DATA TP/6.283185308D+0/,RETA/2.654420938D-3/ 3182 NEQ=N+2*M 3183 NQDS=0 3184 IF (IPR.GT.0.AND.IPR.NE.5) GO TO 5 3185C 3186C APPLIED FIELD OF VOLTAGE SOURCES FOR TRANSMITTING CASE 3187C 3188 DO 1 I=1,NEQ 31891 E(I)=(0.,0.) 3190 IF (NSANT.EQ.0) GO TO 3 3191 DO 2 I=1,NSANT 3192 IS=ISANT(I) 31932 E(IS)=-VSANT(I)/(SI(IS)*WLAM) 31943 IF (NVQD.EQ.0) RETURN 3195 DO 4 I=1,NVQD 3196 IS=IVQD(I) 31974 CALL QDSRC (IS,VQD(I),E) 3198 RETURN 31995 IF (IPR.GT.3) GO TO 19 3200C 3201C INCIDENT PLANE WAVE, LINEARLY POLARIZED. 3202C 3203 CTH=COS(P1) 3204 STH=SIN(P1) 3205 CPH=COS(P2) 3206 SPH=SIN(P2) 3207 CET=COS(P3) 3208 SET=SIN(P3) 3209 PX=CTH*CPH*CET-SPH*SET 3210 PY=CTH*SPH*CET+CPH*SET 3211 PZ=-STH*CET 3212 WX=-STH*CPH 3213 WY=-STH*SPH 3214 WZ=-CTH 3215 QX=WY*PZ-WZ*PY 3216 QY=WZ*PX-WX*PZ 3217 QZ=WX*PY-WY*PX 3218 IF (KSYMP.EQ.1) GO TO 7 3219 IF (IPERF.EQ.1) GO TO 6 3220 RRV=SQRT(1.-ZRATI*ZRATI*STH*STH) 3221 RRH=ZRATI*CTH 3222 RRH=(RRH-RRV)/(RRH+RRV) 3223 RRV=ZRATI*RRV 3224 RRV=-(CTH-RRV)/(CTH+RRV) 3225 GO TO 7 32266 RRV=-(1.,0.) 3227 RRH=-(1.,0.) 32287 IF (IPR.GT.1) GO TO 13 3229 IF (N.EQ.0) GO TO 10 3230 DO 8 I=1,N 3231 ARG=-TP*(WX*X(I)+WY*Y(I)+WZ*Z(I)) 32328 E(I)=-(PX*CAB(I)+PY*SAB(I)+PZ*SALP(I))*DCMPLX(COS(ARG),SIN(ARG)) 3233 IF (KSYMP.EQ.1) GO TO 10 3234 TT1=(PY*CPH-PX*SPH)*(RRH-RRV) 3235 CX=RRV*PX-TT1*SPH 3236 CY=RRV*PY+TT1*CPH 3237 CZ=-RRV*PZ 3238 DO 9 I=1,N 3239 ARG=-TP*(WX*X(I)+WY*Y(I)-WZ*Z(I)) 32409 E(I)=E(I)-(CX*CAB(I)+CY*SAB(I)+CZ*SALP(I))*DCMPLX(COS(ARG), 3241 1SIN(ARG)) 324210 IF (M.EQ.0) RETURN 3243 I=LD+1 3244 I1=N-1 3245 DO 11 IS=1,M 3246 I=I-1 3247 I1=I1+2 3248 I2=I1+1 3249 ARG=-TP*(WX*X(I)+WY*Y(I)+WZ*Z(I)) 3250 TT1=DCMPLX(COS(ARG),SIN(ARG))*SALP(I)*RETA 3251 E(I2)=(QX*T1X(I)+QY*T1Y(I)+QZ*T1Z(I))*TT1 325211 E(I1)=(QX*T2X(I)+QY*T2Y(I)+QZ*T2Z(I))*TT1 3253 IF (KSYMP.EQ.1) RETURN 3254 TT1=(QY*CPH-QX*SPH)*(RRV-RRH) 3255 CX=-(RRH*QX-TT1*SPH) 3256 CY=-(RRH*QY+TT1*CPH) 3257 CZ=RRH*QZ 3258 I=LD+1 3259 I1=N-1 3260 DO 12 IS=1,M 3261 I=I-1 3262 I1=I1+2 3263 I2=I1+1 3264 ARG=-TP*(WX*X(I)+WY*Y(I)-WZ*Z(I)) 3265 TT1=DCMPLX(COS(ARG),SIN(ARG))*SALP(I)*RETA 3266 E(I2)=E(I2)+(CX*T1X(I)+CY*T1Y(I)+CZ*T1Z(I))*TT1 326712 E(I1)=E(I1)+(CX*T2X(I)+CY*T2Y(I)+CZ*T2Z(I))*TT1 3268 RETURN 3269C 3270C INCIDENT PLANE WAVE, ELLIPTIC POLARIZATION. 3271C 327213 TT1=-(0.,1.)*P6 3273 IF (IPR.EQ.3) TT1=-TT1 3274 IF (N.EQ.0) GO TO 16 3275 CX=PX+TT1*QX 3276 CY=PY+TT1*QY 3277 CZ=PZ+TT1*QZ 3278 DO 14 I=1,N 3279 ARG=-TP*(WX*X(I)+WY*Y(I)+WZ*Z(I)) 328014 E(I)=-(CX*CAB(I)+CY*SAB(I)+CZ*SALP(I))*DCMPLX(COS(ARG),SIN(ARG)) 3281 IF (KSYMP.EQ.1) GO TO 16 3282 TT2=(CY*CPH-CX*SPH)*(RRH-RRV) 3283 CX=RRV*CX-TT2*SPH 3284 CY=RRV*CY+TT2*CPH 3285 CZ=-RRV*CZ 3286 DO 15 I=1,N 3287 ARG=-TP*(WX*X(I)+WY*Y(I)-WZ*Z(I)) 328815 E(I)=E(I)-(CX*CAB(I)+CY*SAB(I)+CZ*SALP(I))*DCMPLX(COS(ARG), 3289 1SIN(ARG)) 329016 IF (M.EQ.0) RETURN 3291 CX=QX-TT1*PX 3292 CY=QY-TT1*PY 3293 CZ=QZ-TT1*PZ 3294 I=LD+1 3295 I1=N-1 3296 DO 17 IS=1,M 3297 I=I-1 3298 I1=I1+2 3299 I2=I1+1 3300 ARG=-TP*(WX*X(I)+WY*Y(I)+WZ*Z(I)) 3301 TT2=DCMPLX(COS(ARG),SIN(ARG))*SALP(I)*RETA 3302 E(I2)=(CX*T1X(I)+CY*T1Y(I)+CZ*T1Z(I))*TT2 330317 E(I1)=(CX*T2X(I)+CY*T2Y(I)+CZ*T2Z(I))*TT2 3304 IF (KSYMP.EQ.1) RETURN 3305 TT1=(CY*CPH-CX*SPH)*(RRV-RRH) 3306 CX=-(RRH*CX-TT1*SPH) 3307 CY=-(RRH*CY+TT1*CPH) 3308 CZ=RRH*CZ 3309 I=LD+1 3310 I1=N-1 3311 DO 18 IS=1,M 3312 I=I-1 3313 I1=I1+2 3314 I2=I1+1 3315 ARG=-TP*(WX*X(I)+WY*Y(I)-WZ*Z(I)) 3316 TT1=DCMPLX(COS(ARG),SIN(ARG))*SALP(I)*RETA 3317 E(I2)=E(I2)+(CX*T1X(I)+CY*T1Y(I)+CZ*T1Z(I))*TT1 331818 E(I1)=E(I1)+(CX*T2X(I)+CY*T2Y(I)+CZ*T2Z(I))*TT1 3319 RETURN 3320C 3321C INCIDENT FIELD OF AN ELEMENTARY CURRENT SOURCE. 3322C 332319 WZ=COS(P4) 3324 WX=WZ*COS(P5) 3325 WY=WZ*SIN(P5) 3326 WZ=SIN(P4) 3327 DS=P6*59.958 3328 DSH=P6/(2.*TP) 3329 NPM=N+M 3330 IS=LD+1 3331 I1=N-1 3332 DO 24 I=1,NPM 3333 II=I 3334 IF (I.LE.N) GO TO 20 3335 IS=IS-1 3336 II=IS 3337 I1=I1+2 3338 I2=I1+1 333920 PX=X(II)-P1 3340 PY=Y(II)-P2 3341 PZ=Z(II)-P3 3342 RS=PX*PX+PY*PY+PZ*PZ 3343 IF (RS.LT.1.D-30) GO TO 24 3344 R=SQRT(RS) 3345 PX=PX/R 3346 PY=PY/R 3347 PZ=PZ/R 3348 CTH=PX*WX+PY*WY+PZ*WZ 3349 STH=SQRT(1.-CTH*CTH) 3350 QX=PX-WX*CTH 3351 QY=PY-WY*CTH 3352 QZ=PZ-WZ*CTH 3353 ARG=SQRT(QX*QX+QY*QY+QZ*QZ) 3354 IF (ARG.LT.1.D-30) GO TO 21 3355 QX=QX/ARG 3356 QY=QY/ARG 3357 QZ=QZ/ARG 3358 GO TO 22 335921 QX=1. 3360 QY=0. 3361 QZ=0. 336222 ARG=-TP*R 3363 TT1=DCMPLX(COS(ARG),SIN(ARG)) 3364 IF (I.GT.N) GO TO 23 3365 TT2=DCMPLX(1.D+0,-1.D+0/(R*TP))/RS 3366 ER=DS*TT1*TT2*CTH 3367 ET=.5*DS*TT1*((0.,1.)*TP/R+TT2)*STH 3368 EZH=ER*CTH-ET*STH 3369 ERH=ER*STH+ET*CTH 3370 CX=EZH*WX+ERH*QX 3371 CY=EZH*WY+ERH*QY 3372 CZ=EZH*WZ+ERH*QZ 3373 E(I)=-(CX*CAB(I)+CY*SAB(I)+CZ*SALP(I)) 3374 GO TO 24 337523 PX=WY*QZ-WZ*QY 3376 PY=WZ*QX-WX*QZ 3377 PZ=WX*QY-WY*QX 3378 TT2=DSH*TT1*DCMPLX(1./R,TP)/R*STH*SALP(II) 3379 CX=TT2*PX 3380 CY=TT2*PY 3381 CZ=TT2*PZ 3382 E(I2)=CX*T1X(II)+CY*T1Y(II)+CZ*T1Z(II) 3383 E(I1)=CX*T2X(II)+CY*T2Y(II)+CZ*T2Z(II) 338424 CONTINUE 3385 RETURN 3386 END 3387 SUBROUTINE FACGF (A,B,C,D,BX,IP,IX,NP,N1,MP,M1,N1C,N2C) 3388C *** 3389C DOUBLE PRECISION 6/4/85 3390C 3391 IMPLICIT REAL*8(A-H,O-Z) 3392C *** 3393C FACGF COMPUTES AND FACTORS D-C(INV(A)B). 3394 COMPLEX*16 A,B,C,D,BX,SUM 3395 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 3396 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 3397 DIMENSION A(1), B(N1C,1), C(N1C,1), D(N2C,1), BX(N1C,1), IP(1), IX 3398 1(1) 3399 IF (N2C.EQ.0) RETURN 3400 IBFL=14 3401 IF (ICASX.LT.3) GO TO 1 3402C CONVERT B FROM BLOCKS OF ROWS ON T14 TO BLOCKS OF COL. ON T16 3403 CALL REBLK (B,C,N1C,NPBX,N2C) 3404 IBFL=16 34051 NPB=NPBL 3406 IF (ICASX.EQ.2) REWIND 14 3407C COMPUTE INV(A)B AND WRITE ON TAPE14 3408 DO 2 IB=1,NBBL 3409 IF (IB.EQ.NBBL) NPB=NLBL 3410 IF (ICASX.GT.1) READ (IBFL) ((BX(I,J),I=1,N1C),J=1,NPB) 3411 CALL SOLVES (A,IP,BX,N1C,NPB,NP,N1,MP,M1,13,13) 3412 IF (ICASX.EQ.2) REWIND 14 3413 IF (ICASX.GT.1) WRITE (14) ((BX(I,J),I=1,N1C),J=1,NPB) 34142 CONTINUE 3415 IF (ICASX.EQ.1) GO TO 3 3416 REWIND 11 3417 REWIND 12 3418 REWIND 15 3419 REWIND IBFL 34203 NPC=NPBL 3421C COMPUTE D-C(INV(A)B) AND WRITE ON TAPE11 3422 DO 8 IC=1,NBBL 3423 IF (IC.EQ.NBBL) NPC=NLBL 3424 IF (ICASX.EQ.1) GO TO 4 3425 READ (15) ((C(I,J),I=1,N1C),J=1,NPC) 3426 READ (12) ((D(I,J),I=1,N2C),J=1,NPC) 3427 REWIND 14 34284 NPB=NPBL 3429 NIC=0 3430 DO 7 IB=1,NBBL 3431 IF (IB.EQ.NBBL) NPB=NLBL 3432 IF (ICASX.GT.1) READ (14) ((B(I,J),I=1,N1C),J=1,NPB) 3433 DO 6 I=1,NPB 3434 II=I+NIC 3435 DO 6 J=1,NPC 3436 SUM=(0.,0.) 3437 DO 5 K=1,N1C 34385 SUM=SUM+B(K,I)*C(K,J) 34396 D(II,J)=D(II,J)-SUM 34407 NIC=NIC+NPBL 3441 IF (ICASX.GT.1) WRITE (11) ((D(I,J),I=1,N2C),J=1,NPBL) 34428 CONTINUE 3443 IF (ICASX.EQ.1) GO TO 9 3444 REWIND 11 3445 REWIND 12 3446 REWIND 14 3447 REWIND 15 34489 N1CP=N1C+1 3449C FACTOR D-C(INV(A)B) 3450 IF (ICASX.GT.1) GO TO 10 3451 CALL FACTR (N2C,D,IP(N1CP),N2C) 3452 GO TO 13 345310 IF (ICASX.EQ.4) GO TO 12 3454 NPB=NPBL 3455 IC=0 3456 DO 11 IB=1,NBBL 3457 IF (IB.EQ.NBBL) NPB=NLBL 3458 II=IC+1 3459 IC=IC+N2C*NPB 346011 READ (11) (B(I,1),I=II,IC) 3461 REWIND 11 3462 CALL FACTR (N2C,B,IP(N1CP),N2C) 3463 NIC=N2C*N2C 3464 WRITE (11) (B(I,1),I=1,NIC) 3465 REWIND 11 3466 GO TO 13 346712 NBLSYS=NBLSYM 3468 NPSYS=NPSYM 3469 NLSYS=NLSYM 3470 ICASS=ICASE 3471 NBLSYM=NBBL 3472 NPSYM=NPBL 3473 NLSYM=NLBL 3474 ICASE=3 3475 CALL FACIO (B,N2C,1,IX(N1CP),11,12,16,11) 3476 CALL LUNSCR (B,N2C,1,IP(N1CP),IX(N1CP),12,11,16) 3477 NBLSYM=NBLSYS 3478 NPSYM=NPSYS 3479 NLSYM=NLSYS 3480 ICASE=ICASS 348113 RETURN 3482 END 3483 SUBROUTINE FACIO (A,NROW,NOP,IP,IU1,IU2,IU3,IU4) 3484C *** 3485C DOUBLE PRECISION 6/4/85 3486C 3487 IMPLICIT REAL*8(A-H,O-Z) 3488C *** 3489C 3490C FACIO CONTROLS I/O FOR OUT-OF-CORE FACTORIZATION 3491C 3492 COMPLEX*16 A 3493 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 3494 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 3495 DIMENSION A(NROW,1), IP(NROW) 3496 IT=2*NPSYM*NROW 3497 NBM=NBLSYM-1 3498 I1=1 3499 I2=IT 3500 I3=I2+1 3501 I4=2*IT 3502 TIME=0. 3503 REWIND IU1 3504 REWIND IU2 3505 DO 3 KK=1,NOP 3506 KA=(KK-1)*NROW+1 3507 IFILE3=IU1 3508 IFILE4=IU3 3509 DO 2 IXBLK1=1,NBM 3510 REWIND IU3 3511 REWIND IU4 3512 CALL BLCKIN (A,IFILE3,I1,I2,1,17) 3513 IXBP=IXBLK1+1 3514 DO 1 IXBLK2=IXBP,NBLSYM 3515 CALL BLCKIN (A,IFILE3,I3,I4,1,18) 3516 CALL SECONDS (T1) 3517 CALL LFACTR (A,NROW,IXBLK1,IXBLK2,IP(KA)) 3518 CALL SECONDS (T2) 3519 TIME=TIME+T2-T1 3520 IF (IXBLK2.EQ.IXBP) CALL BLCKOT (A,IU2,I1,I2,1,19) 3521 IF (IXBLK1.EQ.NBM.AND.IXBLK2.EQ.NBLSYM) IFILE4=IU2 3522 CALL BLCKOT (A,IFILE4,I3,I4,1,20) 35231 CONTINUE 3524 IFILE3=IU3 3525 IFILE4=IU4 3526 IF ((IXBLK1/2)*2.NE.IXBLK1) GO TO 2 3527 IFILE3=IU4 3528 IFILE4=IU3 35292 CONTINUE 35303 CONTINUE 3531 REWIND IU1 3532 REWIND IU2 3533 REWIND IU3 3534 REWIND IU4 3535 WRITE(3,4) TIME 3536 RETURN 3537C 35384 FORMAT (35H CP TIME TAKEN FOR FACTORIZATION = ,1P,E12.5) 3539 END 3540 SUBROUTINE FACTR (N,A,IP,NDIM) 3541C *** 3542C DOUBLE PRECISION 6/4/85 3543C 3544 PARAMETER (MAXSEG=1500, MAXMAT=1500) 3545 IMPLICIT REAL*8(A-H,O-Z) 3546C *** 3547C 3548C SUBROUTINE TO FACTOR A MATRIX INTO A UNIT LOWER TRIANGULAR MATRIX 3549C AND AN UPPER TRIANGULAR MATRIX USING THE GAUSS-DOOLITTLE ALGORITHM 3550C PRESENTED ON PAGES 411-416 OF A. RALSTON--A FIRST COURSE IN 3551C NUMERICAL ANALYSIS. COMMENTS BELOW REFER TO COMMENTS IN RALSTONS 3552C TEXT. (MATRIX TRANSPOSED. 3553C 3554 COMPLEX*16 A,D,ARJ 3555 DIMENSION A(NDIM,NDIM), IP(NDIM) 3556 COMMON /SCRATM/ D(2*MAXSEG) 3557 INTEGER R,RM1,RP1,PJ,PR 3558C 3559C Un-transpose the matrix for Gauss elimination 3560C 3561 DO 12 I=2,N 3562 DO 11 J=1,I-1 3563 ARJ=A(I,J) 3564 A(I,J)=A(J,I) 3565 A(J,I)=ARJ 356611 CONTINUE 356712 CONTINUE 3568 IFLG=0 3569C 3570C STEP 1 3571C 3572 DO 9 R=1,N 3573 DO 1 K=1,N 3574 D(K)=A(K,R) 35751 CONTINUE 3576C 3577C STEPS 2 AND 3 3578C 3579 RM1=R-1 3580 IF (RM1.LT.1) GO TO 4 3581 DO 3 J=1,RM1 3582 PJ=IP(J) 3583 ARJ=D(PJ) 3584 A(J,R)=ARJ 3585 D(PJ)=D(J) 3586 JP1=J+1 3587 DO 2 I=JP1,N 3588 D(I)=D(I)-A(I,J)*ARJ 35892 CONTINUE 35903 CONTINUE 35914 CONTINUE 3592C 3593C STEP 4 3594C 3595 DMAX=DREAL(D(R)*DCONJG(D(R))) 3596 IP(R)=R 3597 RP1=R+1 3598 IF (RP1.GT.N) GO TO 6 3599 DO 5 I=RP1,N 3600 ELMAG=DREAL(D(I)*DCONJG(D(I))) 3601 IF (ELMAG.LT.DMAX) GO TO 5 3602 DMAX=ELMAG 3603 IP(R)=I 36045 CONTINUE 36056 CONTINUE 3606 IF (DMAX.LT.1.D-10) IFLG=1 3607 PR=IP(R) 3608 A(R,R)=D(PR) 3609 D(PR)=D(R) 3610C 3611C STEP 5 3612C 3613 IF (RP1.GT.N) GO TO 8 3614 ARJ=1./A(R,R) 3615 DO 7 I=RP1,N 3616 A(I,R)=D(I)*ARJ 36177 CONTINUE 36188 CONTINUE 3619 IF (IFLG.EQ.0) GO TO 9 3620 WRITE(3,10) R,DMAX 3621 IFLG=0 36229 CONTINUE 3623 RETURN 3624C 362510 FORMAT (1H ,6HPIVOT(,I3,2H)=,1P,E16.8) 3626 END 3627 SUBROUTINE FACTRS (NP,NROW,A,IP,IX,IU1,IU2,IU3,IU4) 3628C *** 3629C DOUBLE PRECISION 6/4/85 3630C 3631 IMPLICIT REAL*8(A-H,O-Z) 3632C *** 3633C 3634C FACTRS, FOR SYMMETRIC STRUCTURE, TRANSFORMS SUBMATRICIES TO FORM 3635C MATRICIES OF THE SYMMETRIC MODES AND CALLS ROUTINE TO FACTOR 3636C MATRICIES. IF NO SYMMETRY, THE ROUTINE IS CALLED TO FACTOR THE 3637C COMPLETE MATRIX. 3638C 3639 COMPLEX*16 A 3640 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 3641 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 3642 DIMENSION A(1), IP(NROW), IX(NROW) 3643 NOP=NROW/NP 3644 IF (ICASE.GT.2) GO TO 2 3645 DO 1 KK=1,NOP 3646 KA=(KK-1)*NP+1 36471 CALL FACTR (NP,A(KA),IP(KA),NROW) 3648 RETURN 36492 IF (ICASE.GT.3) GO TO 3 3650C 3651C FACTOR SUBMATRICIES, OR FACTOR COMPLETE MATRIX IF NO SYMMETRY 3652C EXISTS. 3653C 3654 CALL FACIO (A,NROW,NOP,IX,IU1,IU2,IU3,IU4) 3655 CALL LUNSCR (A,NROW,NOP,IP,IX,IU2,IU3,IU4) 3656 RETURN 3657C 3658C REWRITE THE MATRICES BY COLUMNS ON TAPE 13 3659C 36603 I2=2*NPBLK*NROW 3661 REWIND IU2 3662 DO 5 K=1,NOP 3663 REWIND IU1 3664 ICOLS=NPBLK 3665 IR2=K*NP 3666 IR1=IR2-NP+1 3667 DO 5 L=1,NBLOKS 3668 IF (NBLOKS.EQ.1.AND.K.GT.1) GO TO 4 3669 CALL BLCKIN (A,IU1,1,I2,1,602) 3670 IF (L.EQ.NBLOKS) ICOLS=NLAST 36714 IRR1=IR1 3672 IRR2=IR2 3673 DO 5 ICOLDX=1,ICOLS 3674 WRITE (IU2) (A(I),I=IRR1,IRR2) 3675 IRR1=IRR1+NROW 3676 IRR2=IRR2+NROW 36775 CONTINUE 3678 REWIND IU1 3679 REWIND IU2 3680 IF (ICASE.EQ.5) GO TO 8 3681 REWIND IU3 3682 IRR1=NP*NP 3683 DO 7 KK=1,NOP 3684 IR1=1-NP 3685 IR2=0 3686 DO 6 I=1,NP 3687 IR1=IR1+NP 3688 IR2=IR2+NP 36896 READ (IU2) (A(J),J=IR1,IR2) 3690 KA=(KK-1)*NP+1 3691 CALL FACTR (NP,A,IP(KA),NP) 3692 WRITE (IU3) (A(I),I=1,IRR1) 36937 CONTINUE 3694 REWIND IU2 3695 REWIND IU3 3696 RETURN 36978 I2=2*NPSYM*NP 3698 DO 10 KK=1,NOP 3699 J2=NPSYM 3700 DO 10 L=1,NBLSYM 3701 IF (L.EQ.NBLSYM) J2=NLSYM 3702 IR1=1-NP 3703 IR2=0 3704 DO 9 J=1,J2 3705 IR1=IR1+NP 3706 IR2=IR2+NP 37079 READ (IU2) (A(I),I=IR1,IR2) 370810 CALL BLCKOT (A,IU1,1,I2,1,193) 3709 REWIND IU1 3710 CALL FACIO (A,NP,NOP,IX,IU1,IU2,IU3,IU4) 3711 CALL LUNSCR (A,NP,NOP,IP,IX,IU2,IU3,IU4) 3712 RETURN 3713 END 3714 COMPLEX*16 FUNCTION FBAR(P) 3715C *** 3716C DOUBLE PRECISION 6/4/85 3717C 3718 IMPLICIT REAL*8(A-H,O-Z) 3719C *** 3720C 3721C FBAR IS SOMMERFELD ATTENUATION FUNCTION FOR NUMERICAL DISTANCE P 3722C 3723 COMPLEX*16 Z,ZS,SUM,POW,TERM,P,FJ 3724 DIMENSION FJX(2) 3725 EQUIVALENCE (FJ,FJX) 3726 DATA TOSP/1.128379167D+0/,ACCS/1.D-12/,SP/1.772453851D+0/ 3727 1,FJX/0.,1./ 3728 Z=FJ*SQRT(P) 3729 IF (ABS(Z).GT.3.) GO TO 3 3730C 3731C SERIES EXPANSION 3732C 3733 ZS=Z*Z 3734 SUM=Z 3735 POW=Z 3736 DO 1 I=1,100 3737 POW=-POW*ZS/DFLOAT(I) 3738 TERM=POW/(2.*I+1.) 3739 SUM=SUM+TERM 3740 TMS=DREAL(TERM*DCONJG(TERM)) 3741 SMS=DREAL(SUM*DCONJG(SUM)) 3742 IF (TMS/SMS.LT.ACCS) GO TO 2 37431 CONTINUE 37442 FBAR=1.-(1.-SUM*TOSP)*Z*EXP(ZS)*SP 3745 RETURN 3746C 3747C ASYMPTOTIC EXPANSION 3748C 37493 IF (DREAL(Z).GE.0.) GO TO 4 3750 MINUS=1 3751 Z=-Z 3752 GO TO 5 37534 MINUS=0 37545 ZS=.5/(Z*Z) 3755 SUM=(0.,0.) 3756 TERM=(1.,0.) 3757 DO 6 I=1,6 3758 TERM=-TERM*(2.*I-1.)*ZS 37596 SUM=SUM+TERM 3760 IF (MINUS.EQ.1) SUM=SUM-2.*SP*Z*EXP(Z*Z) 3761 FBAR=-SUM 3762 RETURN 3763 END 3764 SUBROUTINE FBLOCK (NROW,NCOL,IMAX,IRNGF,IPSYM) 3765C *** 3766C DOUBLE PRECISION 6/4/85 3767C 3768 IMPLICIT REAL*8(A-H,O-Z) 3769C *** 3770C FBLOCK SETS PARAMETERS FOR OUT-OF-CORE SOLUTION FOR THE PRIMARY 3771C MATRIX (A) 3772 COMPLEX*16 SSX,DETER 3773 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 3774 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 3775 COMMON /SMAT/ SSX(16,16) 3776 IMX1=IMAX-IRNGF 3777 IF (NROW*NCOL.GT.IMX1) GO TO 2 3778 NBLOKS=1 3779 NPBLK=NROW 3780 NLAST=NROW 3781 IMAT=NROW*NCOL 3782 IF (NROW.NE.NCOL) GO TO 1 3783 ICASE=1 3784 RETURN 37851 ICASE=2 3786 GO TO 5 37872 IF (NROW.NE.NCOL) GO TO 3 3788 ICASE=3 3789 NPBLK=IMAX/(2*NCOL) 3790 NPSYM=IMX1/NCOL 3791 IF (NPSYM.LT.NPBLK) NPBLK=NPSYM 3792 IF (NPBLK.LT.1) GO TO 12 3793 NBLOKS=(NROW-1)/NPBLK 3794 NLAST=NROW-NBLOKS*NPBLK 3795 NBLOKS=NBLOKS+1 3796 NBLSYM=NBLOKS 3797 NPSYM=NPBLK 3798 NLSYM=NLAST 3799 IMAT=NPBLK*NCOL 3800 WRITE(3,14) NBLOKS,NPBLK,NLAST 3801 GO TO 11 38023 NPBLK=IMAX/NCOL 3803 IF (NPBLK.LT.1) GO TO 12 3804 IF (NPBLK.GT.NROW) NPBLK=NROW 3805 NBLOKS=(NROW-1)/NPBLK 3806 NLAST=NROW-NBLOKS*NPBLK 3807 NBLOKS=NBLOKS+1 3808 WRITE(3,14) NBLOKS,NPBLK,NLAST 3809 IF (NROW*NROW.GT.IMX1) GO TO 4 3810 ICASE=4 3811 NBLSYM=1 3812 NPSYM=NROW 3813 NLSYM=NROW 3814 IMAT=NROW*NROW 3815 WRITE(3,15) 3816 GO TO 5 38174 ICASE=5 3818 NPSYM=IMAX/(2*NROW) 3819 NBLSYM=IMX1/NROW 3820 IF (NBLSYM.LT.NPSYM) NPSYM=NBLSYM 3821 IF (NPSYM.LT.1) GO TO 12 3822 NBLSYM=(NROW-1)/NPSYM 3823 NLSYM=NROW-NBLSYM*NPSYM 3824 NBLSYM=NBLSYM+1 3825 WRITE(3,16) NBLSYM,NPSYM,NLSYM 3826 IMAT=NPSYM*NROW 38275 NOP=NCOL/NROW 3828 IF (NOP*NROW.NE.NCOL) GO TO 13 3829 IF (IPSYM.GT.0) GO TO 7 3830C 3831C SET UP SSX MATRIX FOR ROTATIONAL SYMMETRY. 3832C 3833 PHAZ=6.2831853072D+0/NOP 3834 DO 6 I=2,NOP 3835 DO 6 J=I,NOP 3836 ARG=PHAZ*DFLOAT(I-1)*DFLOAT(J-1) 3837 SSX(I,J)=DCMPLX(COS(ARG),SIN(ARG)) 38386 SSX(J,I)=SSX(I,J) 3839 GO TO 11 3840C 3841C SET UP SSX MATRIX FOR PLANE SYMMETRY 3842C 38437 KK=1 3844 SSX(1,1)=(1.,0.) 3845 IF ((NOP.EQ.2).OR.(NOP.EQ.4).OR.(NOP.EQ.8)) GO TO 8 3846 STOP 38478 KA=NOP/2 3848 IF (NOP.EQ.8) KA=3 3849 DO 10 K=1,KA 3850 DO 9 I=1,KK 3851 DO 9 J=1,KK 3852 DETER=SSX(I,J) 3853 SSX(I,J+KK)=DETER 3854 SSX(I+KK,J+KK)=-DETER 38559 SSX(I+KK,J)=DETER 385610 KK=KK*2 385711 RETURN 385812 WRITE(3,17) NROW,NCOL 3859 STOP 386013 WRITE(3,18) NROW,NCOL 3861 STOP 3862C 386314 FORMAT (//35H MATRIX FILE STORAGE - NO. BLOCKS=,I5,19H COLUMNS PE 3864 1R BLOCK=,I5,23H COLUMNS IN LAST BLOCK=,I5) 386515 FORMAT (25H SUBMATRICIES FIT IN CORE) 386616 FORMAT (38H SUBMATRIX PARTITIONING - NO. BLOCKS=,I5,19H COLUMNS P 3867 1ER BLOCK=,I5,23H COLUMNS IN LAST BLOCK=,I5) 386817 FORMAT (40H ERROR - INSUFFICIENT STORAGE FOR MATRIX,2I5) 386918 FORMAT (28H SYMMETRY ERROR - NROW,NCOL=,2I5) 3870 END 3871 SUBROUTINE FBNGF (NEQ,NEQ2,IRESRV,IB11,IC11,ID11,IX11) 3872C *** 3873C DOUBLE PRECISION 6/4/85 3874C 3875 IMPLICIT REAL*8(A-H,O-Z) 3876C *** 3877C FBNGF SETS THE BLOCKING PARAMETERS FOR THE B, C, AND D ARRAYS FOR 3878C OUT-OF-CORE STORAGE. 3879 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 3880 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 3881 IRESX=IRESRV-IMAT 3882 NBLN=NEQ*NEQ2 3883 NDLN=NEQ2*NEQ2 3884 NBCD=2*NBLN+NDLN 3885 IF (NBCD.GT.IRESX) GO TO 1 3886 ICASX=1 3887 IB11=IMAT+1 3888 GO TO 2 38891 IF (ICASE.LT.3) GO TO 3 3890 IF (NBCD.GT.IRESRV.OR.NBLN.GT.IRESX) GO TO 3 3891 ICASX=2 3892 IB11=1 38932 NBBX=1 3894 NPBX=NEQ 3895 NLBX=NEQ 3896 NBBL=1 3897 NPBL=NEQ2 3898 NLBL=NEQ2 3899 GO TO 5 39003 IR=IRESRV 3901 IF (ICASE.LT.3) IR=IRESX 3902 ICASX=3 3903 IF (NDLN.GT.IR) ICASX=4 3904 NBCD=2*NEQ+NEQ2 3905 NPBL=IR/NBCD 3906 NLBL=IR/(2*NEQ2) 3907 IF (NLBL.LT.NPBL) NPBL=NLBL 3908 IF (ICASE.LT.3) GO TO 4 3909 NLBL=IRESX/NEQ 3910 IF (NLBL.LT.NPBL) NPBL=NLBL 39114 IF (NPBL.LT.1) GO TO 6 3912 NBBL=(NEQ2-1)/NPBL 3913 NLBL=NEQ2-NBBL*NPBL 3914 NBBL=NBBL+1 3915 NBLN=NEQ*NPBL 3916 IR=IR-NBLN 3917 NPBX=IR/NEQ2 3918 IF (NPBX.GT.NEQ) NPBX=NEQ 3919 NBBX=(NEQ-1)/NPBX 3920 NLBX=NEQ-NBBX*NPBX 3921 NBBX=NBBX+1 3922 IB11=1 3923 IF (ICASE.LT.3) IB11=IMAT+1 39245 IC11=IB11+NBLN 3925 ID11=IC11+NBLN 3926 IX11=IMAT+1 3927 WRITE(3,11) NEQ2 3928 IF (ICASX.EQ.1) RETURN 3929 WRITE(3,8) ICASX 3930 WRITE(3,9) NBBX,NPBX,NLBX 3931 WRITE(3,10) NBBL,NPBL,NLBL 3932 RETURN 39336 WRITE(3,7) IRESRV,IMAT,NEQ,NEQ2 3934 STOP 3935C 39367 FORMAT (55H ERROR - INSUFFICIENT STORAGE FOR INTERACTION MATRICIES 3937 1,24H IRESRV,IMAT,NEQ,NEQ2 =,4I5) 39388 FORMAT (48H FILE STORAGE FOR NEW MATRIX SECTIONS - ICASX =,I2) 39399 FORMAT (19H B FILLED BY ROWS -,15X,12HNO. BLOCKS =,I3,3X,16HROWS P 3940 1ER BLOCK =,I3,3X,20HROWS IN LAST BLOCK =,I3) 394110 FORMAT (32H B BY COLUMNS, C AND D BY ROWS -,2X,12HNO. BLOCKS =,I3, 3942 14X,15HR/C PER BLOCK =,I3,4X,19HR/C IN LAST BLOCK =,I3) 394311 FORMAT (//,35H N.G.F. - NUMBER OF NEW UNKNOWNS IS,I4) 3944 END 3945 SUBROUTINE FFLD (THET,PHI,ETH,EPH) 3946C *** 3947C DOUBLE PRECISION 6/4/85 3948C 3949 PARAMETER (MAXSEG=1500, MAXMAT=1500) 3950 IMPLICIT REAL*8(A-H,O-Z) 3951C *** 3952C 3953C FFLD CALCULATES THE FAR ZONE RADIATED ELECTRIC FIELDS, 3954C THE FACTOR EXP(J*K*R)/(R/LAMDA) NOT INCLUDED 3955C 3956 COMPLEX*16 CIX,CIY,CIZ,EXA,ETH,EPH,CONST,CCX,CCY,CCZ,CDP,CUR 3957 COMPLEX*16 ZRATI,ZRSIN,RRV,RRH,RRV1,RRH1,RRV2,RRH2,ZRATI2,TIX,TIY 3958 1,TIZ,T1,ZSCRN,EX,EY,EZ,GX,GY,GZ,FRATI 3959 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 3960 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 3961 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 3962 COMMON /ANGL/ SALP(MAXSEG) 3963 COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG), 3964 &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG) 3965 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 3966 &KSYMP,IFAR,IPERF 3967 DIMENSION CAB(1), SAB(1), CONSX(2) 3968 EQUIVALENCE (CAB,ALP), (SAB,BET), (CONST,CONSX) 3969 DATA PI,TP,ETA/3.141592654D+0,6.283185308D+0,376.73/ 3970 DATA CONSX/0.,-29.97922085D+0/ 3971 PHX=-SIN(PHI) 3972 PHY=COS(PHI) 3973 ROZ=COS(THET) 3974 ROZS=ROZ 3975 THX=ROZ*PHY 3976 THY=-ROZ*PHX 3977 THZ=-SIN(THET) 3978 ROX=-THZ*PHY 3979 ROY=THZ*PHX 3980 IF (N.EQ.0) GO TO 20 3981C 3982C LOOP FOR STRUCTURE IMAGE IF ANY 3983C 3984 DO 19 K=1,KSYMP 3985C 3986C CALCULATION OF REFLECTION COEFFECIENTS 3987C 3988 IF (K.EQ.1) GO TO 4 3989 IF (IPERF.NE.1) GO TO 1 3990C 3991C FOR PERFECT GROUND 3992C 3993 RRV=-(1.,0.) 3994 RRH=-(1.,0.) 3995 GO TO 2 3996C 3997C FOR INFINITE PLANAR GROUND 3998C 39991 ZRSIN=SQRT(1.-ZRATI*ZRATI*THZ*THZ) 4000 RRV=-(ROZ-ZRATI*ZRSIN)/(ROZ+ZRATI*ZRSIN) 4001 RRH=(ZRATI*ROZ-ZRSIN)/(ZRATI*ROZ+ZRSIN) 40022 IF (IFAR.LE.1) GO TO 3 4003C 4004C FOR THE CLIFF PROBLEM, TWO REFLCTION COEFFICIENTS CALCULATED 4005C 4006 RRV1=RRV 4007 RRH1=RRH 4008 TTHET=TAN(THET) 4009 IF (IFAR.EQ.4) GO TO 3 4010 ZRSIN=SQRT(1.-ZRATI2*ZRATI2*THZ*THZ) 4011 RRV2=-(ROZ-ZRATI2*ZRSIN)/(ROZ+ZRATI2*ZRSIN) 4012 RRH2=(ZRATI2*ROZ-ZRSIN)/(ZRATI2*ROZ+ZRSIN) 4013 DARG=-TP*2.*CH*ROZ 40143 ROZ=-ROZ 4015 CCX=CIX 4016 CCY=CIY 4017 CCZ=CIZ 40184 CIX=(0.,0.) 4019 CIY=(0.,0.) 4020 CIZ=(0.,0.) 4021C 4022C LOOP OVER STRUCTURE SEGMENTS 4023C 4024 DO 17 I=1,N 4025 OMEGA=-(ROX*CAB(I)+ROY*SAB(I)+ROZ*SALP(I)) 4026 EL=PI*SI(I) 4027 SILL=OMEGA*EL 4028 TOP=EL+SILL 4029 BOT=EL-SILL 4030 IF (ABS(OMEGA).LT.1.D-7) GO TO 5 4031 A=2.*SIN(SILL)/OMEGA 4032 GO TO 6 40335 A=(2.-OMEGA*OMEGA*EL*EL/3.)*EL 40346 IF (ABS(TOP).LT.1.D-7) GO TO 7 4035 TOO=SIN(TOP)/TOP 4036 GO TO 8 40377 TOO=1.-TOP*TOP/6. 40388 IF (ABS(BOT).LT.1.D-7) GO TO 9 4039 BOO=SIN(BOT)/BOT 4040 GO TO 10 40419 BOO=1.-BOT*BOT/6. 404210 B=EL*(BOO-TOO) 4043 C=EL*(BOO+TOO) 4044 RR=A*AIR(I)+B*BII(I)+C*CIR(I) 4045 RI=A*AII(I)-B*BIR(I)+C*CII(I) 4046 ARG=TP*(X(I)*ROX+Y(I)*ROY+Z(I)*ROZ) 4047 IF (K.EQ.2.AND.IFAR.GE.2) GO TO 11 4048 EXA=DCMPLX(COS(ARG),SIN(ARG))*DCMPLX(RR,RI) 4049C 4050C SUMMATION FOR FAR FIELD INTEGRAL 4051C 4052 CIX=CIX+EXA*CAB(I) 4053 CIY=CIY+EXA*SAB(I) 4054 CIZ=CIZ+EXA*SALP(I) 4055 GO TO 17 4056C 4057C CALCULATION OF IMAGE CONTRIBUTION IN CLIFF AND GROUND SCREEN 4058C PROBLEMS. 4059C 406011 DR=Z(I)*TTHET 4061C 4062C SPECULAR POINT DISTANCE 4063C 4064 D=DR*PHY+X(I) 4065 IF (IFAR.EQ.2) GO TO 13 4066 D=SQRT(D*D+(Y(I)-DR*PHX)**2) 4067 IF (IFAR.EQ.3) GO TO 13 4068 IF ((SCRWL-D).LT.0.) GO TO 12 4069C 4070C RADIAL WIRE GROUND SCREEN REFLECTION COEFFICIENT 4071C 4072 D=D+T2 4073 ZSCRN=T1*D*LOG(D/T2) 4074 ZSCRN=(ZSCRN*ZRATI)/(ETA*ZRATI+ZSCRN) 4075 ZRSIN=SQRT(1.-ZSCRN*ZSCRN*THZ*THZ) 4076 RRV=(ROZ+ZSCRN*ZRSIN)/(-ROZ+ZSCRN*ZRSIN) 4077 RRH=(ZSCRN*ROZ+ZRSIN)/(ZSCRN*ROZ-ZRSIN) 4078 GO TO 16 407912 IF (IFAR.EQ.4) GO TO 14 4080 IF (IFAR.EQ.5) D=DR*PHY+X(I) 408113 IF ((CL-D).LE.0.) GO TO 15 408214 RRV=RRV1 4083 RRH=RRH1 4084 GO TO 16 408515 RRV=RRV2 4086 RRH=RRH2 4087 ARG=ARG+DARG 408816 EXA=DCMPLX(COS(ARG),SIN(ARG))*DCMPLX(RR,RI) 4089C 4090C CONTRIBUTION OF EACH IMAGE SEGMENT MODIFIED BY REFLECTION COEF. , 4091C FOR CLIFF AND GROUND SCREEN PROBLEMS 4092C 4093 TIX=EXA*CAB(I) 4094 TIY=EXA*SAB(I) 4095 TIZ=EXA*SALP(I) 4096 CDP=(TIX*PHX+TIY*PHY)*(RRH-RRV) 4097 CIX=CIX+TIX*RRV+CDP*PHX 4098 CIY=CIY+TIY*RRV+CDP*PHY 4099 CIZ=CIZ-TIZ*RRV 410017 CONTINUE 4101 IF (K.EQ.1) GO TO 19 4102 IF (IFAR.GE.2) GO TO 18 4103C 4104C CALCULATION OF CONTRIBUTION OF STRUCTURE IMAGE FOR INFINITE GROUND 4105C 4106 CDP=(CIX*PHX+CIY*PHY)*(RRH-RRV) 4107 CIX=CCX+CIX*RRV+CDP*PHX 4108 CIY=CCY+CIY*RRV+CDP*PHY 4109 CIZ=CCZ-CIZ*RRV 4110 GO TO 19 411118 CIX=CIX+CCX 4112 CIY=CIY+CCY 4113 CIZ=CIZ+CCZ 411419 CONTINUE 4115 IF (M.GT.0) GO TO 21 4116 ETH=(CIX*THX+CIY*THY+CIZ*THZ)*CONST 4117 EPH=(CIX*PHX+CIY*PHY)*CONST 4118 RETURN 411920 CIX=(0.,0.) 4120 CIY=(0.,0.) 4121 CIZ=(0.,0.) 412221 ROZ=ROZS 4123C 4124C ELECTRIC FIELD COMPONENTS 4125C 4126 RFL=-1. 4127 DO 25 IP=1,KSYMP 4128 RFL=-RFL 4129 RRZ=ROZ*RFL 4130 CALL FFLDS (ROX,ROY,RRZ,CUR(N+1),GX,GY,GZ) 4131 IF (IP.EQ.2) GO TO 22 4132 EX=GX 4133 EY=GY 4134 EZ=GZ 4135 GO TO 25 413622 IF (IPERF.NE.1) GO TO 23 4137 GX=-GX 4138 GY=-GY 4139 GZ=-GZ 4140 GO TO 24 414123 RRV=SQRT(1.-ZRATI*ZRATI*THZ*THZ) 4142 RRH=ZRATI*ROZ 4143 RRH=(RRH-RRV)/(RRH+RRV) 4144 RRV=ZRATI*RRV 4145 RRV=-(ROZ-RRV)/(ROZ+RRV) 4146 ETH=(GX*PHX+GY*PHY)*(RRH-RRV) 4147 GX=GX*RRV+ETH*PHX 4148 GY=GY*RRV+ETH*PHY 4149 GZ=GZ*RRV 415024 EX=EX+GX 4151 EY=EY+GY 4152 EZ=EZ-GZ 415325 CONTINUE 4154 EX=EX+CIX*CONST 4155 EY=EY+CIY*CONST 4156 EZ=EZ+CIZ*CONST 4157 ETH=EX*THX+EY*THY+EZ*THZ 4158 EPH=EX*PHX+EY*PHY 4159 RETURN 4160 END 4161 SUBROUTINE FFLDS (ROX,ROY,ROZ,SCUR,EX,EY,EZ) 4162C *** 4163C DOUBLE PRECISION 6/4/85 4164C 4165 PARAMETER (MAXSEG=1500, MAXMAT=1500) 4166 IMPLICIT REAL*8(A-H,O-Z) 4167C *** 4168C CALCULATES THE XYZ COMPONENTS OF THE ELECTRIC FIELD DUE TO 4169C SURFACE CURRENTS 4170 COMPLEX*16 CT,CONS,SCUR,EX,EY,EZ 4171 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 4172 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 4173 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 4174 DIMENSION XS(1), YS(1), ZS(1), S(1), SCUR(1), CONSX(2) 4175 EQUIVALENCE (XS,X), (YS,Y), (ZS,Z), (S,BI), (CONS,CONSX) 4176 DATA TPI/6.283185308D+0/,CONSX/0.,188.365/ 4177 EX=(0.,0.) 4178 EY=(0.,0.) 4179 EZ=(0.,0.) 4180 I=LD+1 4181 DO 1 J=1,M 4182 I=I-1 4183 ARG=TPI*(ROX*XS(I)+ROY*YS(I)+ROZ*ZS(I)) 4184 CT=DCMPLX(COS(ARG)*S(I),SIN(ARG)*S(I)) 4185 K=3*J 4186 EX=EX+SCUR(K-2)*CT 4187 EY=EY+SCUR(K-1)*CT 4188 EZ=EZ+SCUR(K)*CT 41891 CONTINUE 4190 CT=ROX*EX+ROY*EY+ROZ*EZ 4191 EX=CONS*(CT*ROX-EX) 4192 EY=CONS*(CT*ROY-EY) 4193 EZ=CONS*(CT*ROZ-EZ) 4194 RETURN 4195 END 4196 SUBROUTINE GF (ZK,CO,SI) 4197C *** 4198C DOUBLE PRECISION 6/4/85 4199C 4200 IMPLICIT REAL*8(A-H,O-Z) 4201C *** 4202C 4203C GF COMPUTES THE INTEGRAND EXP(JKR)/(KR) FOR NUMERICAL INTEGRATION. 4204C 4205 COMMON /TMI/ ZPK,RKB2,IJ 4206 ZDK=ZK-ZPK 4207 RK=SQRT(RKB2+ZDK*ZDK) 4208 SI=SIN(RK)/RK 4209 IF (IJ) 1,2,1 42101 CO=COS(RK)/RK 4211 RETURN 42122 IF (RK.LT..2) GO TO 3 4213 CO=(COS(RK)-1.)/RK 4214 RETURN 42153 RKS=RK*RK 4216 CO=((-1.38888889D-3*RKS+4.16666667D-2)*RKS-.5)*RK 4217 RETURN 4218 END 4219 SUBROUTINE GFIL (IPRT) 4220C *** 4221C DOUBLE PRECISION 6/4/85 4222C 4223 PARAMETER (MAXSEG=1500, MAXMAT=1500) 4224 PARAMETER (IRESRV=MAXMAT**2) 4225 IMPLICIT REAL*8(A-H,O-Z) 4226C *** 4227C 4228C GFIL READS THE N.G.F. FILE 4229C 4230 COMPLEX*16 CM,SSX,ZRATI,ZRATI2,T1,ZARRAY,AR1,AR2,AR3,EPSCF,FRATI 4231 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 4232 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 4233 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 4234 COMMON /CMB/ CM(IRESRV) 4235 COMMON /ANGL/ SALP(MAXSEG) 4236 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 4237 &KSYMP,IFAR,IPERF 4238 COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),DY 4239 1A(3),XSA(3),YSA(3),NXA(3),NYA(3) 4240 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 4241 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 4242 COMMON /SMAT/ SSX(16,16) 4243 COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF 4244 COMMON/SAVE/EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(2*MAXSEG),KCOM 4245 COMMON/CSAVE/COM(19,5) 4246C 4247C*** ERROR CORRECTED 11/20/89 ******************************* 4248 DIMENSION T2X(1),T2Y(1),T2Z(1) 4249 EQUIVALENCE (T2X,ICON1),(T2Y,ICON2),(T2Z,ITAG) 4250C*** 4251 DATA IGFL/20/ 4252 OPEN(UNIT=IGFL,FILE='NGF2D.NEC',FORM='UNFORMATTED',STATUS='OLD') 4253 REWIND IGFL 4254 READ (IGFL) N1,NP,M1,MP,WLAM,FMHZ,IPSYM,KSYMP,IPERF,NRADL,EPSR,SIG 4255 1,SCRWLT,SCRWRT,NLODF,KCOM 4256 N=N1 4257 M=M1 4258 N2=N1+1 4259 M2=M1+1 4260 IF (N1.EQ.0) GO TO 2 4261C READ SEG. DATA AND CONVERT BACK TO END COORD. IN UNITS OF METERS 4262 READ (IGFL) (X(I),I=1,N1),(Y(I),I=1,N1),(Z(I),I=1,N1) 4263 READ (IGFL) (SI(I),I=1,N1),(BI(I),I=1,N1),(ALP(I),I=1,N1) 4264 READ (IGFL) (BET(I),I=1,N1),(SALP(I),I=1,N1) 4265 READ (IGFL) (ICON1(I),I=1,N1),(ICON2(I),I=1,N1) 4266 READ (IGFL) (ITAG(I),I=1,N1) 4267 IF (NLODF.NE.0) READ (IGFL) (ZARRAY(I),I=1,N1) 4268 DO 1 I=1,N1 4269 XI=X(I)*WLAM 4270 YI=Y(I)*WLAM 4271 ZI=Z(I)*WLAM 4272 DX=SI(I)*.5*WLAM 4273 X(I)=XI-ALP(I)*DX 4274 Y(I)=YI-BET(I)*DX 4275 Z(I)=ZI-SALP(I)*DX 4276 SI(I)=XI+ALP(I)*DX 4277 ALP(I)=YI+BET(I)*DX 4278 BET(I)=ZI+SALP(I)*DX 4279 BI(I)=BI(I)*WLAM 42801 CONTINUE 42812 IF (M1.EQ.0) GO TO 4 4282 J=LD-M1+1 4283C READ PATCH DATA AND CONVERT TO METERS 4284 READ (IGFL) (X(I),I=J,LD),(Y(I),I=J,LD),(Z(I),I=J,LD) 4285 READ (IGFL) (SI(I),I=J,LD),(BI(I),I=J,LD),(ALP(I),I=J,LD) 4286 READ (IGFL) (BET(I),I=J,LD),(SALP(I),I=J,LD) 4287C*** ERROR CORRECTED 11/20/89 ******************************* 4288 READ (IGFL) (T2X(I),I=J,LD),(T2Y(I),I=J,LD) 4289 READ (IGFL) (T2Z(I),I=J,LD) 4290C READ (IGFL) (ICON1(I),I=J,LD),(ICON2(I),I=J,LD) 4291C READ (IGFL) (ITAG(I),I=J,LD) 4292C 4293 DX=WLAM*WLAM 4294 DO 3 I=J,LD 4295 X(I)=X(I)*WLAM 4296 Y(I)=Y(I)*WLAM 4297 Z(I)=Z(I)*WLAM 42983 BI(I)=BI(I)*DX 42994 READ (IGFL) ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT 4300 IF (IPERF.EQ.2) READ (IGFL) AR1,AR2,AR3,EPSCF,DXA,DYA,XSA,YSA,NXA, 4301 1NYA 4302 NEQ=N1+2*M1 4303 NPEQ=NP+2*MP 4304 NOP=NEQ/NPEQ 4305 IF (NOP.GT.1) READ (IGFL) ((SSX(I,J),I=1,NOP),J=1,NOP) 4306 READ (IGFL) (IP(I),I=1,NEQ),COM 4307C READ MATRIX A AND WRITE TAPE13 FOR OUT OF CORE 4308 IF (ICASE.GT.2) GO TO 5 4309 IOUT=NEQ*NPEQ 4310 READ (IGFL) (CM(I),I=1,IOUT) 4311 GO TO 10 43125 REWIND 13 4313 IF (ICASE.NE.4) GO TO 7 4314 IOUT=NPEQ*NPEQ 4315 DO 6 K=1,NOP 4316 READ (IGFL) (CM(J),J=1,IOUT) 43176 WRITE (13) (CM(J),J=1,IOUT) 4318 GO TO 9 43197 IOUT=NPSYM*NPEQ*2 4320 NBL2=2*NBLSYM 4321 DO 8 IOP=1,NOP 4322 DO 8 I=1,NBL2 4323 CALL BLCKIN (CM,IGFL,1,IOUT,1,206) 43248 CALL BLCKOT (CM,13,1,IOUT,1,205) 43259 REWIND 13 432610 REWIND IGFL 4327C WRITE(3,N) G.F. HEADING 4328 WRITE(3,16) 4329 WRITE(3,14) 4330 WRITE(3,14) 4331 WRITE(3,17) 4332 WRITE(3,18) N1,M1 4333 IF (NOP.GT.1) WRITE(3,19) NOP 4334 WRITE(3,20) IMAT,ICASE 4335 IF (ICASE.LT.3) GO TO 11 4336 NBL2=NEQ*NPEQ 4337 WRITE(3,21) NBL2 433811 WRITE(3,22) FMHZ 4339 IF (KSYMP.EQ.2.AND.IPERF.EQ.1) WRITE(3,23) 4340 IF (KSYMP.EQ.2.AND.IPERF.EQ.0) WRITE(3,27) 4341 IF (KSYMP.EQ.2.AND.IPERF.EQ.2) WRITE(3,28) 4342 IF (KSYMP.EQ.2.AND.IPERF.NE.1) WRITE(3,24) EPSR,SIG 4343 WRITE(3,17) 4344 DO 12 J=1,KCOM 434512 WRITE(3,15) (COM(I,J),I=1,19) 4346 WRITE(3,17) 4347 WRITE(3,14) 4348 WRITE(3,14) 4349 WRITE(3,16) 4350 IF (IPRT.EQ.0) RETURN 4351 WRITE(3,25) 4352 DO 13 I=1,N1 435313 WRITE(3,26) I,X(I),Y(I),Z(I),SI(I),ALP(I),BET(I) 4354 RETURN 4355C 435614 FORMAT (5X,50H**************************************************, 4357 &34H**********************************) 435815 FORMAT (5X,3H** ,19A4,3H **) 435916 FORMAT (////) 436017 FORMAT (5X,2H**,80X,2H**) 436118 FORMAT (5X,29H** NUMERICAL GREEN'S FUNCTION,53X,2H**,/,5X,17H** NO 4362 1. SEGMENTS =,I4,10X,13HNO. PATCHES =,I4,34X,2H**) 436319 FORMAT (5X,27H** NO. SYMMETRIC SECTIONS =,I4,51X,2H**) 436420 FORMAT (5X,34H** N.G.F. MATRIX - CORE STORAGE =,I7,23H COMPLEX NU 4365 1MBERS, CASE,I2,16X,2H**) 436621 FORMAT (5X,2H**,19X,13HMATRIX SIZE =,I7,16H COMPLEX NUMBERS,25X,2H 4367 1**) 436822 FORMAT (5X,14H** FREQUENCY =,1P,E12.5,5H MHZ.,51X,2H**) 436923 FORMAT (5X,17H** PERFECT GROUND,65X,2H**) 437024 FORMAT (5X,44H** GROUND PARAMETERS - DIELECTRIC CONSTANT =,1P, 4371 1E12.5,26X,2H**,/,5X,2H**,21X,14HCONDUCTIVITY =,E12.5,8H MHOS/M., 4372 225X,2H**) 437325 FORMAT (39X,31HNUMERICAL GREEN'S FUNCTION DATA,/,41X,27HCOORDINATE 4374 1S OF SEGMENT ENDS,/,51X,8H(METERS),/,5X,4HSEG.,11X,19H- - - END ON 4375 2E - - -,26X,19H- - - END TWO - - -,/,6X,3HNO.,6X,1HX,14X,1HY,14X,1 4376 3HZ,14X,1HX,14X,1HY,14X,1HZ) 437726 FORMAT (1X,I7,1P,6E15.6) 437827 FORMAT (5X,55H** FINITE GROUND. REFLECTION COEFFICIENT APPROXIMAT 4379 1ION,27X,2H**) 438028 FORMAT (5X,38H** FINITE GROUND. SOMMERFELD SOLUTION,44X,2H**) 4381 END 4382 SUBROUTINE GFLD (RHO,PHI,RZ,ETH,EPI,ERD,UX,KSYMP) 4383C *** 4384C DOUBLE PRECISION 6/4/85 4385C 4386 PARAMETER (MAXSEG=1500, MAXMAT=1500) 4387 IMPLICIT REAL*8(A-H,O-Z) 4388C *** 4389C 4390C GFLD COMPUTES THE RADIATED FIELD INCLUDING GROUND WAVE. 4391C 4392 COMPLEX*16 CUR,EPI,CIX,CIY,CIZ,EXA,XX1,XX2,U,U2,ERV,EZV,ERH,EPH 4393 COMPLEX*16 EZH,EX,EY,ETH,UX,ERD 4394 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 4395 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 4396 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 4397 COMMON /ANGL/ SALP(MAXSEG) 4398 COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG), 4399 &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG) 4400 COMMON /GWAV/ U,U2,XX1,XX2,R1,R2,ZMH,ZPH 4401 DIMENSION CAB(1), SAB(1) 4402 EQUIVALENCE (CAB(1),ALP(1)), (SAB(1),BET(1)) 4403 DATA PI,TP/3.141592654D+0,6.283185308D+0/ 4404 R=SQRT(RHO*RHO+RZ*RZ) 4405 IF (KSYMP.EQ.1) GO TO 1 4406 IF (ABS(UX).GT..5) GO TO 1 4407 IF (R.GT.1.E5) GO TO 1 4408 GO TO 4 4409C 4410C COMPUTATION OF SPACE WAVE ONLY 4411C 44121 IF (RZ.LT.1.D-20) GO TO 2 4413 THET=ATAN(RHO/RZ) 4414 GO TO 3 44152 THET=PI*.5 44163 CALL FFLD (THET,PHI,ETH,EPI) 4417 ARG=-TP*R 4418 EXA=DCMPLX(COS(ARG),SIN(ARG))/R 4419 ETH=ETH*EXA 4420 EPI=EPI*EXA 4421 ERD=(0.,0.) 4422 RETURN 4423C 4424C COMPUTATION OF SPACE AND GROUND WAVES. 4425C 44264 U=UX 4427 U2=U*U 4428 PHX=-SIN(PHI) 4429 PHY=COS(PHI) 4430 RX=RHO*PHY 4431 RY=-RHO*PHX 4432 CIX=(0.,0.) 4433 CIY=(0.,0.) 4434 CIZ=(0.,0.) 4435C 4436C SUMMATION OF FIELD FROM INDIVIDUAL SEGMENTS 4437C 4438 DO 17 I=1,N 4439 DX=CAB(I) 4440 DY=SAB(I) 4441 DZ=SALP(I) 4442 RIX=RX-X(I) 4443 RIY=RY-Y(I) 4444 RHS=RIX*RIX+RIY*RIY 4445 RHP=SQRT(RHS) 4446 IF (RHP.LT.1.D-6) GO TO 5 4447 RHX=RIX/RHP 4448 RHY=RIY/RHP 4449 GO TO 6 44505 RHX=1. 4451 RHY=0. 44526 CALP=1.-DZ*DZ 4453 IF (CALP.LT.1.D-6) GO TO 7 4454 CALP=SQRT(CALP) 4455 CBET=DX/CALP 4456 SBET=DY/CALP 4457 CPH=RHX*CBET+RHY*SBET 4458 SPH=RHY*CBET-RHX*SBET 4459 GO TO 8 44607 CPH=RHX 4461 SPH=RHY 44628 EL=PI*SI(I) 4463 RFL=-1. 4464C 4465C INTEGRATION OF (CURRENT)*(PHASE FACTOR) OVER SEGMENT AND IMAGE FOR 4466C CONSTANT, SINE, AND COSINE CURRENT DISTRIBUTIONS 4467C 4468 DO 16 K=1,2 4469 RFL=-RFL 4470 RIZ=RZ-Z(I)*RFL 4471 RXYZ=SQRT(RIX*RIX+RIY*RIY+RIZ*RIZ) 4472 RNX=RIX/RXYZ 4473 RNY=RIY/RXYZ 4474 RNZ=RIZ/RXYZ 4475 OMEGA=-(RNX*DX+RNY*DY+RNZ*DZ*RFL) 4476 SILL=OMEGA*EL 4477 TOP=EL+SILL 4478 BOT=EL-SILL 4479 IF (ABS(OMEGA).LT.1.D-7) GO TO 9 4480 A=2.*SIN(SILL)/OMEGA 4481 GO TO 10 44829 A=(2.-OMEGA*OMEGA*EL*EL/3.)*EL 448310 IF (ABS(TOP).LT.1.D-7) GO TO 11 4484 TOO=SIN(TOP)/TOP 4485 GO TO 12 448611 TOO=1.-TOP*TOP/6. 448712 IF (ABS(BOT).LT.1.D-7) GO TO 13 4488 BOO=SIN(BOT)/BOT 4489 GO TO 14 449013 BOO=1.-BOT*BOT/6. 449114 B=EL*(BOO-TOO) 4492 C=EL*(BOO+TOO) 4493 RR=A*AIR(I)+B*BII(I)+C*CIR(I) 4494 RI=A*AII(I)-B*BIR(I)+C*CII(I) 4495 ARG=TP*(X(I)*RNX+Y(I)*RNY+Z(I)*RNZ*RFL) 4496 EXA=DCMPLX(COS(ARG),SIN(ARG))*DCMPLX(RR,RI)/TP 4497 IF (K.EQ.2) GO TO 15 4498 XX1=EXA 4499 R1=RXYZ 4500 ZMH=RIZ 4501 GO TO 16 450215 XX2=EXA 4503 R2=RXYZ 4504 ZPH=RIZ 450516 CONTINUE 4506C 4507C CALL SUBROUTINE TO COMPUTE THE FIELD OF SEGMENT INCLUDING GROUND 4508C WAVE. 4509C 4510 CALL GWAVE (ERV,EZV,ERH,EZH,EPH) 4511 ERH=ERH*CPH*CALP+ERV*DZ 4512 EPH=EPH*SPH*CALP 4513 EZH=EZH*CPH*CALP+EZV*DZ 4514 EX=ERH*RHX-EPH*RHY 4515 EY=ERH*RHY+EPH*RHX 4516 CIX=CIX+EX 4517 CIY=CIY+EY 451817 CIZ=CIZ+EZH 4519 ARG=-TP*R 4520 EXA=DCMPLX(COS(ARG),SIN(ARG)) 4521 CIX=CIX*EXA 4522 CIY=CIY*EXA 4523 CIZ=CIZ*EXA 4524 RNX=RX/R 4525 RNY=RY/R 4526 RNZ=RZ/R 4527 THX=RNZ*PHY 4528 THY=-RNZ*PHX 4529 THZ=-RHO/R 4530 ETH=CIX*THX+CIY*THY+CIZ*THZ 4531 EPI=CIX*PHX+CIY*PHY 4532 ERD=CIX*RNX+CIY*RNY+CIZ*RNZ 4533 RETURN 4534 END 4535 SUBROUTINE GFOUT 4536C *** 4537C DOUBLE PRECISION 6/4/85 4538C 4539 PARAMETER (MAXSEG=1500, MAXMAT=1500) 4540 PARAMETER (IRESRV=MAXMAT**2) 4541 IMPLICIT REAL*8(A-H,O-Z) 4542C *** 4543C 4544C WRITE N.G.F. FILE 4545C 4546 COMPLEX*16 CM,SSX,ZRATI,ZRATI2,T1,ZARRAY,AR1,AR2,AR3,EPSCF,FRATI 4547 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 4548 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 4549 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 4550 COMMON /CMB/ CM(IRESRV) 4551 COMMON /ANGL/ SALP(MAXSEG) 4552 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 4553 &KSYMP,IFAR,IPERF 4554 COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),DY 4555 1A(3),XSA(3),YSA(3),NXA(3),NYA(3) 4556 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 4557 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 4558 COMMON /SMAT/ SSX(16,16) 4559 COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF 4560 COMMON/SAVE/EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(2*MAXSEG),KCOM 4561 COMMON/CSAVE/COM(19,5) 4562C 4563C*** ERROR CORRECTED 11/20/89 ******************************* 4564 DIMENSION T2X(1),T2Y(1),T2Z(1) 4565 EQUIVALENCE (T2X,ICON1),(T2Y,ICON2),(T2Z,ITAG) 4566C*** 4567 DATA IGFL/20/ 4568 OPEN(UNIT=IGFL,FILE='NGF2D.NEC',FORM='UNFORMATTED',STATUS='NEW') 4569 NEQ=N+2*M 4570 NPEQ=NP+2*MP 4571 NOP=NEQ/NPEQ 4572 WRITE (IGFL) N,NP,M,MP,WLAM,FMHZ,IPSYM,KSYMP,IPERF,NRADL,EPSR, 4573 1SIG,SCRWLT,SCRWRT,NLOAD,KCOM 4574 IF (N.EQ.0) GO TO 1 4575 WRITE (IGFL) (X(I),I=1,N),(Y(I),I=1,N),(Z(I),I=1,N) 4576 WRITE (IGFL) (SI(I),I=1,N),(BI(I),I=1,N),(ALP(I),I=1,N) 4577 WRITE (IGFL) (BET(I),I=1,N),(SALP(I),I=1,N) 4578 WRITE (IGFL) (ICON1(I),I=1,N),(ICON2(I),I=1,N) 4579 WRITE (IGFL) (ITAG(I),I=1,N) 4580 IF (NLOAD.GT.0) WRITE (IGFL) (ZARRAY(I),I=1,N) 45811 IF (M.EQ.0) GO TO 2 4582 J=LD-M+1 4583 WRITE (IGFL) (X(I),I=J,LD),(Y(I),I=J,LD),(Z(I),I=J,LD) 4584 WRITE (IGFL) (SI(I),I=J,LD),(BI(I),I=J,LD),(ALP(I),I=J,LD) 4585 WRITE (IGFL) (BET(I),I=J,LD),(SALP(I),I=J,LD) 4586C 4587C*** ERROR CORRECTED 11/20/89 ******************************* 4588 4589 WRITE (IGFL) (T2X(I),I=J,LD),(T2Y(I),I=J,LD) 4590 WRITE (IGFL) (T2Z(I),I=J,LD) 4591C WRITE (IGFL) (ICON1(I),I=J,LD),(ICON2(I),I=J,LD) 4592C WRITE (IGFL) (ITAG(I),I=J,LD) 4593C 45942 WRITE (IGFL) ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT 4595 IF (IPERF.EQ.2) WRITE (IGFL) AR1,AR2,AR3,EPSCF,DXA,DYA,XSA,YSA,NXA 4596 1,NYA 4597 IF (NOP.GT.1) WRITE (IGFL) ((SSX(I,J),I=1,NOP),J=1,NOP) 4598 WRITE (IGFL) (IP(I),I=1,NEQ),COM 4599 IF (ICASE.GT.2) GO TO 3 4600 IOUT=NEQ*NPEQ 4601 WRITE (IGFL) (CM(I),I=1,IOUT) 4602 GO TO 12 46033 IF (ICASE.NE.4) GO TO 5 4604 REWIND 13 4605 I=NPEQ*NPEQ 4606 DO 4 K=1,NOP 4607 READ (13) (CM(J),J=1,I) 46084 WRITE (IGFL) (CM(J),J=1,I) 4609 REWIND 13 4610 GO TO 12 46115 REWIND 13 4612 REWIND 14 4613 IF (ICASE.EQ.5) GO TO 8 4614 IOUT=NPBLK*NEQ*2 4615 DO 6 I=1,NBLOKS 4616 CALL BLCKIN (CM,13,1,IOUT,1,201) 46176 CALL BLCKOT (CM,IGFL,1,IOUT,1,202) 4618 DO 7 I=1,NBLOKS 4619 CALL BLCKIN (CM,14,1,IOUT,1,203) 46207 CALL BLCKOT (CM,IGFL,1,IOUT,1,204) 4621 GO TO 12 46228 IOUT=NPSYM*NPEQ*2 4623 DO 11 IOP=1,NOP 4624 DO 9 I=1,NBLSYM 4625 CALL BLCKIN (CM,13,1,IOUT,1,205) 46269 CALL BLCKOT (CM,IGFL,1,IOUT,1,206) 4627 DO 10 I=1,NBLSYM 4628 CALL BLCKIN (CM,14,1,IOUT,1,207) 462910 CALL BLCKOT (CM,IGFL,1,IOUT,1,208) 463011 CONTINUE 4631 REWIND 13 4632 REWIND 14 463312 REWIND IGFL 4634 WRITE(3,13) IGFL,IMAT 4635 RETURN 4636C 463713 FORMAT (///,44H ****NUMERICAL GREEN'S FUNCTION FILE ON TAPE,I3,5H 4638 1****,/,5X,16HMATRIX STORAGE -,I7,16H COMPLEX NUMBERS,///) 4639 END 4640 SUBROUTINE GH (ZK,HR,HI) 4641C *** 4642C DOUBLE PRECISION 6/4/85 4643C 4644 IMPLICIT REAL*8(A-H,O-Z) 4645C *** 4646C INTEGRAND FOR H FIELD OF A WIRE 4647 COMMON /TMH/ ZPK,RHKS 4648 RS=ZK-ZPK 4649 RS=RHKS+RS*RS 4650 R=SQRT(RS) 4651 CKR=COS(R) 4652 SKR=SIN(R) 4653 RR2=1./RS 4654 RR3=RR2/R 4655 HR=SKR*RR2+CKR*RR3 4656 HI=CKR*RR2-SKR*RR3 4657 RETURN 4658 END 4659 SUBROUTINE GWAVE (ERV,EZV,ERH,EZH,EPH) 4660C *** 4661C DOUBLE PRECISION 6/4/85 4662C 4663 IMPLICIT REAL*8(A-H,O-Z) 4664C *** 4665C 4666C GWAVE COMPUTES THE ELECTRIC FIELD, INCLUDING GROUND WAVE, OF A 4667C CURRENT ELEMENT OVER A GROUND PLANE USING FORMULAS OF K.A. NORTON 4668C (PROC. IRE, SEPT., 1937, PP.1203,1236.) 4669C 4670 COMPLEX*16 FJ,TPJ,U2,U,RK1,RK2,T1,T2,T3,T4,P1,RV,OMR,W,F,Q1,RH,V,G 4671 1,XR1,XR2,X1,X2,X3,X4,X5,X6,X7,EZV,ERV,EZH,ERH,EPH,XX1,XX2,ECON, 4672 2FBAR 4673 COMMON /GWAV/ U,U2,XX1,XX2,R1,R2,ZMH,ZPH 4674 DIMENSION FJX(2), TPJX(2), ECONX(2) 4675 EQUIVALENCE (FJ,FJX), (TPJ,TPJX), (ECON,ECONX) 4676 DATA PI/3.141592654D+0/,FJX/0.,1./,TPJX/0.,6.283185308D+0/ 4677 DATA ECONX/0.,-188.367/ 4678 SPPP=ZMH/R1 4679 SPPP2=SPPP*SPPP 4680 CPPP2=1.-SPPP2 4681 IF (CPPP2.LT.1.D-20) CPPP2=1.D-20 4682 CPPP=SQRT(CPPP2) 4683 SPP=ZPH/R2 4684 SPP2=SPP*SPP 4685 CPP2=1.-SPP2 4686 IF (CPP2.LT.1.D-20) CPP2=1.D-20 4687 CPP=SQRT(CPP2) 4688 RK1=-TPJ*R1 4689 RK2=-TPJ*R2 4690 T1=1.-U2*CPP2 4691 T2=SQRT(T1) 4692 T3=(1.-1./RK1)/RK1 4693 T4=(1.-1./RK2)/RK2 4694 P1=RK2*U2*T1/(2.*CPP2) 4695 RV=(SPP-U*T2)/(SPP+U*T2) 4696 OMR=1.-RV 4697 W=1./OMR 4698 W=(4.,0.)*P1*W*W 4699 F=FBAR(W) 4700 Q1=RK2*T1/(2.*U2*CPP2) 4701 RH=(T2-U*SPP)/(T2+U*SPP) 4702 V=1./(1.+RH) 4703 V=(4.,0.)*Q1*V*V 4704 G=FBAR(V) 4705 XR1=XX1/R1 4706 XR2=XX2/R2 4707 X1=CPPP2*XR1 4708 X2=RV*CPP2*XR2 4709 X3=OMR*CPP2*F*XR2 4710 X4=U*T2*SPP*2.*XR2/RK2 4711 X5=XR1*T3*(1.-3.*SPPP2) 4712 X6=XR2*T4*(1.-3.*SPP2) 4713 EZV=(X1+X2+X3-X4-X5-X6)*ECON 4714 X1=SPPP*CPPP*XR1 4715 X2=RV*SPP*CPP*XR2 4716 X3=CPP*OMR*U*T2*F*XR2 4717 X4=SPP*CPP*OMR*XR2/RK2 4718 X5=3.*SPPP*CPPP*T3*XR1 4719 X6=CPP*U*T2*OMR*XR2/RK2*.5 4720 X7=3.*SPP*CPP*T4*XR2 4721 ERV=-(X1+X2-X3+X4-X5+X6-X7)*ECON 4722 EZH=-(X1-X2+X3-X4-X5-X6+X7)*ECON 4723 X1=SPPP2*XR1 4724 X2=RV*SPP2*XR2 4725 X4=U2*T1*OMR*F*XR2 4726 X5=T3*(1.-3.*CPPP2)*XR1 4727 X6=T4*(1.-3.*CPP2)*(1.-U2*(1.+RV)-U2*OMR*F)*XR2 4728 X7=U2*CPP2*OMR*(1.-1./RK2)*(F*(U2*T1-SPP2-1./RK2)+1./RK2)*XR2 4729 ERH=(X1-X2-X4-X5+X6+X7)*ECON 4730 X1=XR1 4731 X2=RH*XR2 4732 X3=(RH+1.)*G*XR2 4733 X4=T3*XR1 4734 X5=T4*(1.-U2*(1.+RV)-U2*OMR*F)*XR2 4735 X6=.5*U2*OMR*(F*(U2*T1-SPP2-1./RK2)+1./RK2)*XR2/RK2 4736 EPH=-(X1-X2+X3-X4+X5+X6)*ECON 4737 RETURN 4738 END 4739 SUBROUTINE GX (ZZ,RH,XK,GZ,GZP) 4740C *** 4741C DOUBLE PRECISION 6/4/85 4742C 4743 IMPLICIT REAL*8(A-H,O-Z) 4744C *** 4745C SEGMENT END CONTRIBUTIONS FOR THIN WIRE APPROX. 4746 COMPLEX*16 GZ,GZP 4747 R2=ZZ*ZZ+RH*RH 4748 R=SQRT(R2) 4749 RK=XK*R 4750 GZ=DCMPLX(COS(RK),-SIN(RK))/R 4751 GZP=-DCMPLX(1.D+0,RK)*GZ/R2 4752 RETURN 4753 END 4754 SUBROUTINE GXX (ZZ,RH,A,A2,XK,IRA,G1,G1P,G2,G2P,G3,GZP) 4755C *** 4756C DOUBLE PRECISION 6/4/85 4757C 4758 IMPLICIT REAL*8(A-H,O-Z) 4759C *** 4760C SEGMENT END CONTRIBUTIONS FOR EXT. THIN WIRE APPROX. 4761 COMPLEX*16 GZ,C1,C2,C3,G1,G1P,G2,G2P,G3,GZP 4762 R2=ZZ*ZZ+RH*RH 4763 R=SQRT(R2) 4764 R4=R2*R2 4765 RK=XK*R 4766 RK2=RK*RK 4767 RH2=RH*RH 4768 T1=.25*A2*RH2/R4 4769 T2=.5*A2/R2 4770 C1=DCMPLX(1.D+0,RK) 4771 C2=3.*C1-RK2 4772 C3=DCMPLX(6.D+0,RK)*RK2-15.*C1 4773 GZ=DCMPLX(COS(RK),-SIN(RK))/R 4774 G2=GZ*(1.+T1*C2) 4775 G1=G2-T2*C1*GZ 4776 GZ=GZ/R2 4777 G2P=GZ*(T1*C3-C1) 4778 GZP=T2*C2*GZ 4779 G3=G2P+GZP 4780 G1P=G3*ZZ 4781 IF (IRA.EQ.1) GO TO 2 4782 G3=(G3+GZP)*RH 4783 GZP=-ZZ*C1*GZ 4784 IF (RH.GT.1.D-10) GO TO 1 4785 G2=0. 4786 G2P=0. 4787 RETURN 47881 G2=G2/RH 4789 G2P=G2P*ZZ/RH 4790 RETURN 47912 T2=.5*A 4792 G2=-T2*C1*GZ 4793 G2P=T2*GZ*C2/R2 4794 G3=RH2*G2P-A*GZ*C1 4795 G2P=G2P*ZZ 4796 GZP=-ZZ*C1*GZ 4797 RETURN 4798 END 4799 SUBROUTINE HELIX(S,HL,A1,B1,A2,B2,RAD,NS,ITG) 4800C *** 4801C DOUBLE PRECISION 6/4/85 4802C 4803 PARAMETER (MAXSEG=1500, MAXMAT=1500) 4804 IMPLICIT REAL*8(A-H,O-Z) 4805C *** 4806C SUBROUTINE HELIX GENERATES SEGMENT GEOMETRY DATA FOR A HELIX OF NS 4807C SEGMENTS 4808 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 4809 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 4810 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 4811 DIMENSION X2(1),Y2(1),Z2(1) 4812 EQUIVALENCE (X2(1),SI(1)), (Y2(1),ALP(1)), (Z2(1),BET(1)) 4813 DATA PI/3.1415926D+0/ 4814 IST=N+1 4815 N=N+NS 4816 NP=N 4817 MP=M 4818 IPSYM=0 4819 IF(NS.LT.1) RETURN 4820 TURNS=ABS(HL/S) 4821 ZINC=ABS(HL/NS) 4822 Z(IST)=0. 4823 DO 25 I=IST,N 4824 BI(I)=RAD 4825 ITAG(I)=ITG 4826 IF(I.NE.IST) Z(I)=Z(I-1)+ZINC 4827 Z2(I)=Z(I)+ZINC 4828 IF(A2.NE.A1) GO TO 10 4829 IF(B1.EQ.0) B1=A1 4830 X(I)=A1*COS(2.*PI*Z(I)/S) 4831 Y(I)=B1*SIN(2.*PI*Z(I)/S) 4832 X2(I)=A1*COS(2.*PI*Z2(I)/S) 4833 Y2(I)=B1*SIN(2.*PI*Z2(I)/S) 4834 GO TO 20 483510 IF(B2.EQ.0) B2=A2 4836 X(I)=(A1+(A2-A1)*Z(I)/ABS(HL))*COS(2.*PI*Z(I)/S) 4837 Y(I)=(B1+(B2-B1)*Z(I)/ABS(HL))*SIN(2.*PI*Z(I)/S) 4838 X2(I)=(A1+(A2-A1)*Z2(I)/ABS(HL))*COS(2.*PI*Z2(I)/S) 4839 Y2(I)=(B1+(B2-B1)*Z2(I)/ABS(HL))*SIN(2.*PI*Z2(I)/S) 484020 IF(HL.GT.0) GO TO 25 4841 COPY=X(I) 4842 X(I)=Y(I) 4843 Y(I)=COPY 4844 COPY=X2(I) 4845 X2(I)=Y2(I) 4846 Y2(I)=COPY 484725 CONTINUE 4848 IF(A2.EQ.A1) GO TO 21 4849 SANGLE=ATAN(A2/(ABS(HL)+(ABS(HL)*A1)/(A2-A1))) 4850 WRITE(3,104) SANGLE 4851104 FORMAT(5X,'THE CONE ANGLE OF THE SPIRAL IS',F10.4) 4852 RETURN 485321 IF(A1.NE.B1) GO TO 30 4854 HDIA=2.*A1 4855 TURN=HDIA*PI 4856 PITCH=ATAN(S/(PI*HDIA)) 4857 TURN=TURN/COS(PITCH) 4858 PITCH=180.*PITCH/PI 4859 GO TO 40 486030 IF(A1.LT.B1) GO TO 34 4861 HMAJ=2.*A1 4862 HMIN=2.*B1 4863 GO TO 35 486434 HMAJ=2.*B1 4865 HMIN=2.*A1 486635 HDIA=SQRT((HMAJ**2+HMIN**2)/2*HMAJ) 4867 TURN=2.*PI*HDIA 4868 PITCH=(180./PI)*ATAN(S/(PI*HDIA)) 486940 WRITE(3,105) PITCH,TURN 4870105 FORMAT(5X,'THE PITCH ANGLE IS',F10.4/5X,'THE LENGTH OF WIRE/TURN I 4871 1S',F10.4) 4872 RETURN 4873 END 4874 SUBROUTINE HFK (EL1,EL2,RHK,ZPKX,SGR,SGI) 4875C *** 4876C DOUBLE PRECISION 6/4/85 4877C 4878 IMPLICIT REAL*8(A-H,O-Z) 4879C *** 4880C HFK COMPUTES THE H FIELD OF A UNIFORM CURRENT FILAMENT BY 4881C NUMERICAL INTEGRATION 4882 COMMON /TMH/ ZPK,RHKS 4883 DATA NX,NM,NTS,RX/1,65536,4,1.D-4/ 4884 ZPK=ZPKX 4885 RHKS=RHK*RHK 4886 Z=EL1 4887 ZE=EL2 4888 S=ZE-Z 4889 EP=S/(10.*NM) 4890 ZEND=ZE-EP 4891 SGR=0.0 4892 SGI=0.0 4893 NS=NX 4894 NT=0 4895 CALL GH (Z,G1R,G1I) 48961 DZ=S/NS 4897 ZP=Z+DZ 4898 IF (ZP-ZE) 3,3,2 48992 DZ=ZE-Z 4900 IF (ABS(DZ)-EP) 17,17,3 49013 DZOT=DZ*.5 4902 ZP=Z+DZOT 4903 CALL GH (ZP,G3R,G3I) 4904 ZP=Z+DZ 4905 CALL GH (ZP,G5R,G5I) 49064 T00R=(G1R+G5R)*DZOT 4907 T00I=(G1I+G5I)*DZOT 4908 T01R=(T00R+DZ*G3R)*0.5 4909 T01I=(T00I+DZ*G3I)*0.5 4910 T10R=(4.0*T01R-T00R)/3.0 4911 T10I=(4.0*T01I-T00I)/3.0 4912 CALL TEST (T01R,T10R,TE1R,T01I,T10I,TE1I,0.D0) 4913 IF (TE1I-RX) 5,5,6 49145 IF (TE1R-RX) 8,8,6 49156 ZP=Z+DZ*0.25 4916 CALL GH (ZP,G2R,G2I) 4917 ZP=Z+DZ*0.75 4918 CALL GH (ZP,G4R,G4I) 4919 T02R=(T01R+DZOT*(G2R+G4R))*0.5 4920 T02I=(T01I+DZOT*(G2I+G4I))*0.5 4921 T11R=(4.0*T02R-T01R)/3.0 4922 T11I=(4.0*T02I-T01I)/3.0 4923 T20R=(16.0*T11R-T10R)/15.0 4924 T20I=(16.0*T11I-T10I)/15.0 4925 CALL TEST (T11R,T20R,TE2R,T11I,T20I,TE2I,0.D0) 4926 IF (TE2I-RX) 7,7,14 49277 IF (TE2R-RX) 9,9,14 49288 SGR=SGR+T10R 4929 SGI=SGI+T10I 4930 NT=NT+2 4931 GO TO 10 49329 SGR=SGR+T20R 4933 SGI=SGI+T20I 4934 NT=NT+1 493510 Z=Z+DZ 4936 IF (Z-ZEND) 11,17,17 493711 G1R=G5R 4938 G1I=G5I 4939 IF (NT-NTS) 1,12,12 494012 IF (NS-NX) 1,1,13 494113 NS=NS/2 4942 NT=1 4943 GO TO 1 494414 NT=0 4945 IF (NS-NM) 16,15,15 494615 WRITE(3,18) Z 4947 GO TO 9 494816 NS=NS*2 4949 DZ=S/NS 4950 DZOT=DZ*0.5 4951 G5R=G3R 4952 G5I=G3I 4953 G3R=G2R 4954 G3I=G2I 4955 GO TO 4 495617 CONTINUE 4957 SGR=SGR*RHK*.5 4958 SGI=SGI*RHK*.5 4959 RETURN 4960C 496118 FORMAT (24H STEP SIZE LIMITED AT Z=,F10.5) 4962 END 4963 SUBROUTINE HINTG (XI,YI,ZI) 4964C *** 4965C DOUBLE PRECISION 6/4/85 4966C 4967 IMPLICIT REAL*8(A-H,O-Z) 4968C *** 4969C HINTG COMPUTES THE H FIELD OF A PATCH CURRENT 4970 COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,ZRATI,ZRATI2,GAM 4971 1,F1X,F1Y,F1Z,F2X,F2Y,F2Z,RRV,RRH,T1,FRATI 4972 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 4973 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 4974 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 4975 &KSYMP,IFAR,IPERF 4976 EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y 4977 1J,IND1), (T2ZJ,IND2) 4978 DATA FPI/12.56637062D+0/,TP/6.283185308D+0/ 4979 RX=XI-XJ 4980 RY=YI-YJ 4981 RFL=-1. 4982 EXK=(0.,0.) 4983 EYK=(0.,0.) 4984 EZK=(0.,0.) 4985 EXS=(0.,0.) 4986 EYS=(0.,0.) 4987 EZS=(0.,0.) 4988 DO 5 IP=1,KSYMP 4989 RFL=-RFL 4990 RZ=ZI-ZJ*RFL 4991 RSQ=RX*RX+RY*RY+RZ*RZ 4992 IF (RSQ.LT.1.D-20) GO TO 5 4993 R=SQRT(RSQ) 4994 RK=TP*R 4995 CR=COS(RK) 4996 SR=SIN(RK) 4997 GAM=-(DCMPLX(CR,-SR)+RK*DCMPLX(SR,CR))/(FPI*RSQ*R)*S 4998 EXC=GAM*RX 4999 EYC=GAM*RY 5000 EZC=GAM*RZ 5001 T1ZR=T1ZJ*RFL 5002 T2ZR=T2ZJ*RFL 5003 F1X=EYC*T1ZR-EZC*T1YJ 5004 F1Y=EZC*T1XJ-EXC*T1ZR 5005 F1Z=EXC*T1YJ-EYC*T1XJ 5006 F2X=EYC*T2ZR-EZC*T2YJ 5007 F2Y=EZC*T2XJ-EXC*T2ZR 5008 F2Z=EXC*T2YJ-EYC*T2XJ 5009 IF (IP.EQ.1) GO TO 4 5010 IF (IPERF.NE.1) GO TO 1 5011 F1X=-F1X 5012 F1Y=-F1Y 5013 F1Z=-F1Z 5014 F2X=-F2X 5015 F2Y=-F2Y 5016 F2Z=-F2Z 5017 GO TO 4 50181 XYMAG=SQRT(RX*RX+RY*RY) 5019 IF (XYMAG.GT.1.D-6) GO TO 2 5020 PX=0. 5021 PY=0. 5022 CTH=1. 5023 RRV=(1.,0.) 5024 GO TO 3 50252 PX=-RY/XYMAG 5026 PY=RX/XYMAG 5027 CTH=RZ/R 5028 RRV=SQRT(1.-ZRATI*ZRATI*(1.-CTH*CTH)) 50293 RRH=ZRATI*CTH 5030 RRH=(RRH-RRV)/(RRH+RRV) 5031 RRV=ZRATI*RRV 5032 RRV=-(CTH-RRV)/(CTH+RRV) 5033 GAM=(F1X*PX+F1Y*PY)*(RRV-RRH) 5034 F1X=F1X*RRH+GAM*PX 5035 F1Y=F1Y*RRH+GAM*PY 5036 F1Z=F1Z*RRH 5037 GAM=(F2X*PX+F2Y*PY)*(RRV-RRH) 5038 F2X=F2X*RRH+GAM*PX 5039 F2Y=F2Y*RRH+GAM*PY 5040 F2Z=F2Z*RRH 50414 EXK=EXK+F1X 5042 EYK=EYK+F1Y 5043 EZK=EZK+F1Z 5044 EXS=EXS+F2X 5045 EYS=EYS+F2Y 5046 EZS=EZS+F2Z 50475 CONTINUE 5048 RETURN 5049 END 5050 SUBROUTINE HSFLD (XI,YI,ZI,AI) 5051C *** 5052C DOUBLE PRECISION 6/4/85 5053C 5054 IMPLICIT REAL*8(A-H,O-Z) 5055C *** 5056C HSFLD COMPUTES THE H FIELD FOR CONSTANT, SINE, AND COSINE CURRENT 5057C ON A SEGMENT INCLUDING GROUND EFFECTS. 5058 COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,ZRATI,ZRATI2,T1 5059 1,HPK,HPS,HPC,QX,QY,QZ,RRV,RRH,ZRATX,FRATI 5060 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 5061 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 5062 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 5063 &KSYMP,IFAR,IPERF 5064 DATA ETA/376.73/ 5065 XIJ=XI-XJ 5066 YIJ=YI-YJ 5067 RFL=-1. 5068 DO 7 IP=1,KSYMP 5069 RFL=-RFL 5070 SALPR=SALPJ*RFL 5071 ZIJ=ZI-RFL*ZJ 5072 ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR 5073 RHOX=XIJ-CABJ*ZP 5074 RHOY=YIJ-SABJ*ZP 5075 RHOZ=ZIJ-SALPR*ZP 5076 RH=SQRT(RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ+AI*AI) 5077 IF (RH.GT.1.D-10) GO TO 1 5078 EXK=0. 5079 EYK=0. 5080 EZK=0. 5081 EXS=0. 5082 EYS=0. 5083 EZS=0. 5084 EXC=0. 5085 EYC=0. 5086 EZC=0. 5087 GO TO 7 50881 RHOX=RHOX/RH 5089 RHOY=RHOY/RH 5090 RHOZ=RHOZ/RH 5091 PHX=SABJ*RHOZ-SALPR*RHOY 5092 PHY=SALPR*RHOX-CABJ*RHOZ 5093 PHZ=CABJ*RHOY-SABJ*RHOX 5094 CALL HSFLX (S,RH,ZP,HPK,HPS,HPC) 5095 IF (IP.NE.2) GO TO 6 5096 IF (IPERF.EQ.1) GO TO 5 5097 ZRATX=ZRATI 5098 RMAG=SQRT(ZP*ZP+RH*RH) 5099 XYMAG=SQRT(XIJ*XIJ+YIJ*YIJ) 5100C 5101C SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN. 5102C 5103 IF (NRADL.EQ.0) GO TO 2 5104 XSPEC=(XI*ZJ+ZI*XJ)/(ZI+ZJ) 5105 YSPEC=(YI*ZJ+ZI*YJ)/(ZI+ZJ) 5106 RHOSPC=SQRT(XSPEC*XSPEC+YSPEC*YSPEC+T2*T2) 5107 IF (RHOSPC.GT.SCRWL) GO TO 2 5108 RRV=T1*RHOSPC*LOG(RHOSPC/T2) 5109 ZRATX=(RRV*ZRATI)/(ETA*ZRATI+RRV) 51102 IF (XYMAG.GT.1.D-6) GO TO 3 5111C 5112C CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED. 5113C 5114 PX=0. 5115 PY=0. 5116 CTH=1. 5117 RRV=(1.,0.) 5118 GO TO 4 51193 PX=-YIJ/XYMAG 5120 PY=XIJ/XYMAG 5121 CTH=ZIJ/RMAG 5122 RRV=SQRT(1.-ZRATX*ZRATX*(1.-CTH*CTH)) 51234 RRH=ZRATX*CTH 5124 RRH=-(RRH-RRV)/(RRH+RRV) 5125 RRV=ZRATX*RRV 5126 RRV=(CTH-RRV)/(CTH+RRV) 5127 QY=(PHX*PX+PHY*PY)*(RRV-RRH) 5128 QX=QY*PX+PHX*RRH 5129 QY=QY*PY+PHY*RRH 5130 QZ=PHZ*RRH 5131 EXK=EXK-HPK*QX 5132 EYK=EYK-HPK*QY 5133 EZK=EZK-HPK*QZ 5134 EXS=EXS-HPS*QX 5135 EYS=EYS-HPS*QY 5136 EZS=EZS-HPS*QZ 5137 EXC=EXC-HPC*QX 5138 EYC=EYC-HPC*QY 5139 EZC=EZC-HPC*QZ 5140 GO TO 7 51415 EXK=EXK-HPK*PHX 5142 EYK=EYK-HPK*PHY 5143 EZK=EZK-HPK*PHZ 5144 EXS=EXS-HPS*PHX 5145 EYS=EYS-HPS*PHY 5146 EZS=EZS-HPS*PHZ 5147 EXC=EXC-HPC*PHX 5148 EYC=EYC-HPC*PHY 5149 EZC=EZC-HPC*PHZ 5150 GO TO 7 51516 EXK=HPK*PHX 5152 EYK=HPK*PHY 5153 EZK=HPK*PHZ 5154 EXS=HPS*PHX 5155 EYS=HPS*PHY 5156 EZS=HPS*PHZ 5157 EXC=HPC*PHX 5158 EYC=HPC*PHY 5159 EZC=HPC*PHZ 51607 CONTINUE 5161 RETURN 5162 END 5163 SUBROUTINE HSFLX (S,RH,ZPX,HPK,HPS,HPC) 5164C *** 5165C DOUBLE PRECISION 6/4/85 5166C 5167 IMPLICIT REAL*8(A-H,O-Z) 5168C *** 5169C CALCULATES H FIELD OF SINE COSINE, AND CONSTANT CURRENT OF SEGMENT 5170 COMPLEX*16 FJ,FJK,EKR1,EKR2,T1,T2,CONS,HPS,HPC,HPK 5171 DIMENSION FJX(2), FJKX(2) 5172 EQUIVALENCE (FJ,FJX), (FJK,FJKX) 5173 DATA TP/6.283185308D+0/,FJX/0.,1./,FJKX/0.,-6.283185308D+0/ 5174 DATA PI8/25.13274123D+0/ 5175 IF (RH.LT.1.D-10) GO TO 6 5176 IF (ZPX.LT.0.) GO TO 1 5177 ZP=ZPX 5178 HSS=1. 5179 GO TO 2 51801 ZP=-ZPX 5181 HSS=-1. 51822 DH=.5*S 5183 Z1=ZP+DH 5184 Z2=ZP-DH 5185 IF (Z2.LT.1.D-7) GO TO 3 5186 RHZ=RH/Z2 5187 GO TO 4 51883 RHZ=1. 51894 DK=TP*DH 5190 CDK=COS(DK) 5191 SDK=SIN(DK) 5192 CALL HFK (-DK,DK,RH*TP,ZP*TP,HKR,HKI) 5193 HPK=DCMPLX(HKR,HKI) 5194 IF (RHZ.LT.1.D-3) GO TO 5 5195 RH2=RH*RH 5196 R1=SQRT(RH2+Z1*Z1) 5197 R2=SQRT(RH2+Z2*Z2) 5198 EKR1=EXP(FJK*R1) 5199 EKR2=EXP(FJK*R2) 5200 T1=Z1*EKR1/R1 5201 T2=Z2*EKR2/R2 5202 HPS=(CDK*(EKR2-EKR1)-FJ*SDK*(T2+T1))*HSS 5203 HPC=-SDK*(EKR2+EKR1)-FJ*CDK*(T2-T1) 5204 CONS=-FJ/(2.*TP*RH) 5205 HPS=CONS*HPS 5206 HPC=CONS*HPC 5207 RETURN 52085 EKR1=DCMPLX(CDK,SDK)/(Z2*Z2) 5209 EKR2=DCMPLX(CDK,-SDK)/(Z1*Z1) 5210 T1=TP*(1./Z1-1./Z2) 5211 T2=EXP(FJK*ZP)*RH/PI8 5212 HPS=T2*(T1+(EKR1+EKR2)*SDK)*HSS 5213 HPC=T2*(-FJ*T1+(EKR1-EKR2)*CDK) 5214 RETURN 52156 HPS=(0.,0.) 5216 HPC=(0.,0.) 5217 HPK=(0.,0.) 5218 RETURN 5219 END 5220 SUBROUTINE INTRP (X,Y,F1,F2,F3,F4) 5221C *** 5222C DOUBLE PRECISION 6/4/85 5223C 5224 IMPLICIT REAL*8(A-H,O-Z) 5225C *** 5226C 5227C INTRP USES BIVARIATE CUBIC INTERPOLATION TO OBTAIN THE VALUES OF 5228C 4 FUNCTIONS AT THE POINT (X,Y). 5229C 5230 SAVE 5231 COMPLEX*16 F1,F2,F3,F4,A,B,C,D,FX1,FX2,FX3,FX4,P1,P2,P3,P4,A11,A12 5232 1,A13,A14,A21,A22,A23,A24,A31,A32,A33,A34,A41,A42,A43,A44,B11,B12 5233 2,B13,B14,B21,B22,B23,B24,B31,B32,B33,B34,B41,B42,B43,B44,C11,C12 5234 3,C13,C14,C21,C22,C23,C24,C31,C32,C33,C34,C41,C42,C43,C44,D11,D12 5235 4,D13,D14,D21,D22,D23,D24,D31,D32,D33,D34,D41,D42,D43,D44 5236 COMPLEX*16 AR1,AR2,AR3,ARL1,ARL2,ARL3,EPSCF 5237 COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),DY 5238 1A(3),XSA(3),YSA(3),NXA(3),NYA(3) 5239 DIMENSION NDA(3), NDPA(3) 5240 DIMENSION A(4,4), B(4,4), C(4,4), D(4,4) 5241 DIMENSION ARL1(1), ARL2(1), ARL3(1) 5242 EQUIVALENCE (ARL1,AR1), (ARL2,AR2), (ARL3,AR3) 5243 EQUIVALENCE (A(1,1),A11), (A(1,2),A12), (A(1,3),A13), (A(1,4),A14) 5244 EQUIVALENCE (A(2,1),A21), (A(2,2),A22), (A(2,3),A23), (A(2,4),A24) 5245 EQUIVALENCE (A(3,1),A31), (A(3,2),A32), (A(3,3),A33), (A(3,4),A34) 5246 EQUIVALENCE (A(4,1),A41), (A(4,2),A42), (A(4,3),A43), (A(4,4),A44) 5247 EQUIVALENCE (B(1,1),B11), (B(1,2),B12), (B(1,3),B13), (B(1,4),B14) 5248 EQUIVALENCE (B(2,1),B21), (B(2,2),B22), (B(2,3),B23), (B(2,4),B24) 5249 EQUIVALENCE (B(3,1),B31), (B(3,2),B32), (B(3,3),B33), (B(3,4),B34) 5250 EQUIVALENCE (B(4,1),B41), (B(4,2),B42), (B(4,3),B43), (B(4,4),B44) 5251 EQUIVALENCE (C(1,1),C11), (C(1,2),C12), (C(1,3),C13), (C(1,4),C14) 5252 EQUIVALENCE (C(2,1),C21), (C(2,2),C22), (C(2,3),C23), (C(2,4),C24) 5253 EQUIVALENCE (C(3,1),C31), (C(3,2),C32), (C(3,3),C33), (C(3,4),C34) 5254 EQUIVALENCE (C(4,1),C41), (C(4,2),C42), (C(4,3),C43), (C(4,4),C44) 5255 EQUIVALENCE (D(1,1),D11), (D(1,2),D12), (D(1,3),D13), (D(1,4),D14) 5256 EQUIVALENCE (D(2,1),D21), (D(2,2),D22), (D(2,3),D23), (D(2,4),D24) 5257 EQUIVALENCE (D(3,1),D31), (D(3,2),D32), (D(3,3),D33), (D(3,4),D34) 5258 EQUIVALENCE (D(4,1),D41), (D(4,2),D42), (D(4,3),D43), (D(4,4),D44) 5259 EQUIVALENCE (XS2,XSA(2)), (YS3,YSA(3)) 5260 DATA IXS,IYS,IGRS/-10,-10,-10/,DX,DY,XS,YS/1.,1.,0.,0./ 5261 DATA NDA/11,17,9/,NDPA/110,85,72/,IXEG,IYEG/0,0/ 5262 IF (X.LT.XS.OR.Y.LT.YS) GO TO 1 5263 IX=INT((X-XS)/DX)+1 5264 IY=INT((Y-YS)/DY)+1 5265C 5266C IF POINT LIES IN SAME 4 BY 4 POINT REGION AS PREVIOUS POINT, OLD 5267C VALUES ARE REUSED 5268C 5269 IF (IX.LT.IXEG.OR.IY.LT.IYEG) GO TO 1 5270 IF (IABS(IX-IXS).LT.2.AND.IABS(IY-IYS).LT.2) GO TO 12 5271C 5272C DETERMINE CORRECT GRID AND GRID REGION 5273C 52741 IF (X.GT.XS2) GO TO 2 5275 IGR=1 5276 GO TO 3 52772 IGR=2 5278 IF (Y.GT.YS3) IGR=3 52793 IF (IGR.EQ.IGRS) GO TO 4 5280 IGRS=IGR 5281 DX=DXA(IGRS) 5282 DY=DYA(IGRS) 5283 XS=XSA(IGRS) 5284 YS=YSA(IGRS) 5285 NXM2=NXA(IGRS)-2 5286 NYM2=NYA(IGRS)-2 5287 NXMS=((NXM2+1)/3)*3+1 5288 NYMS=((NYM2+1)/3)*3+1 5289 ND=NDA(IGRS) 5290 NDP=NDPA(IGRS) 5291 IX=INT((X-XS)/DX)+1 5292 IY=INT((Y-YS)/DY)+1 52934 IXS=((IX-1)/3)*3+2 5294 IF (IXS.LT.2) IXS=2 5295 IXEG=-10000 5296 IF (IXS.LE.NXM2) GO TO 5 5297 IXS=NXM2 5298 IXEG=NXMS 52995 IYS=((IY-1)/3)*3+2 5300 IF (IYS.LT.2) IYS=2 5301 IYEG=-10000 5302 IF (IYS.LE.NYM2) GO TO 6 5303 IYS=NYM2 5304 IYEG=NYMS 5305C 5306C COMPUTE COEFFICIENTS OF 4 CUBIC POLYNOMIALS IN X FOR THE 4 GRID 5307C VALUES OF Y FOR EACH OF THE 4 FUNCTIONS 5308C 53096 IADZ=IXS+(IYS-3)*ND-NDP 5310 DO 11 K=1,4 5311 IADZ=IADZ+NDP 5312 IADD=IADZ 5313 DO 11 I=1,4 5314 IADD=IADD+ND 5315 GO TO (7,8,9), IGRS 5316C P1=AR1(IXS-1,IYS-2+I,K) 53177 P1=ARL1(IADD-1) 5318 P2=ARL1(IADD) 5319 P3=ARL1(IADD+1) 5320 P4=ARL1(IADD+2) 5321 GO TO 10 53228 P1=ARL2(IADD-1) 5323 P2=ARL2(IADD) 5324 P3=ARL2(IADD+1) 5325 P4=ARL2(IADD+2) 5326 GO TO 10 53279 P1=ARL3(IADD-1) 5328 P2=ARL3(IADD) 5329 P3=ARL3(IADD+1) 5330 P4=ARL3(IADD+2) 533110 A(I,K)=(P4-P1+3.*(P2-P3))*.1666666667D+0 5332 B(I,K)=(P1-2.*P2+P3)*.5 5333 C(I,K)=P3-(2.*P1+3.*P2+P4)*.1666666667D+0 533411 D(I,K)=P2 5335 XZ=(IXS-1)*DX+XS 5336 YZ=(IYS-1)*DY+YS 5337C 5338C EVALUATE POLYMOMIALS IN X AND THEN USE CUBIC INTERPOLATION IN Y 5339C FOR EACH OF THE 4 FUNCTIONS. 5340C 534112 XX=(X-XZ)/DX 5342 YY=(Y-YZ)/DY 5343 FX1=((A11*XX+B11)*XX+C11)*XX+D11 5344 FX2=((A21*XX+B21)*XX+C21)*XX+D21 5345 FX3=((A31*XX+B31)*XX+C31)*XX+D31 5346 FX4=((A41*XX+B41)*XX+C41)*XX+D41 5347 P1=FX4-FX1+3.*(FX2-FX3) 5348 P2=3.*(FX1-2.*FX2+FX3) 5349 P3=6.*FX3-2.*FX1-3.*FX2-FX4 5350 F1=((P1*YY+P2)*YY+P3)*YY*.1666666667D+0+FX2 5351 FX1=((A12*XX+B12)*XX+C12)*XX+D12 5352 FX2=((A22*XX+B22)*XX+C22)*XX+D22 5353 FX3=((A32*XX+B32)*XX+C32)*XX+D32 5354 FX4=((A42*XX+B42)*XX+C42)*XX+D42 5355 P1=FX4-FX1+3.*(FX2-FX3) 5356 P2=3.*(FX1-2.*FX2+FX3) 5357 P3=6.*FX3-2.*FX1-3.*FX2-FX4 5358 F2=((P1*YY+P2)*YY+P3)*YY*.1666666667D+0+FX2 5359 FX1=((A13*XX+B13)*XX+C13)*XX+D13 5360 FX2=((A23*XX+B23)*XX+C23)*XX+D23 5361 FX3=((A33*XX+B33)*XX+C33)*XX+D33 5362 FX4=((A43*XX+B43)*XX+C43)*XX+D43 5363 P1=FX4-FX1+3.*(FX2-FX3) 5364 P2=3.*(FX1-2.*FX2+FX3) 5365 P3=6.*FX3-2.*FX1-3.*FX2-FX4 5366 F3=((P1*YY+P2)*YY+P3)*YY*.1666666667D+0+FX2 5367 FX1=((A14*XX+B14)*XX+C14)*XX+D14 5368 FX2=((A24*XX+B24)*XX+C24)*XX+D24 5369 FX3=((A34*XX+B34)*XX+C34)*XX+D34 5370 FX4=((A44*XX+B44)*XX+C44)*XX+D44 5371 P1=FX4-FX1+3.*(FX2-FX3) 5372 P2=3.*(FX1-2.*FX2+FX3) 5373 P3=6.*FX3-2.*FX1-3.*FX2-FX4 5374 F4=((P1*YY+P2)*YY+P3)*YY*.1666666667D+0+FX2 5375 RETURN 5376 END 5377 SUBROUTINE INTX (EL1,EL2,B,IJ,SGR,SGI) 5378C *** 5379C DOUBLE PRECISION 6/4/85 5380C 5381 IMPLICIT REAL*8(A-H,O-Z) 5382C *** 5383C 5384C INTX PERFORMS NUMERICAL INTEGRATION OF EXP(JKR)/R BY THE METHOD OF 5385C VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION. THE INTEGRAND VALUE 5386C IS SUPPLIED BY SUBROUTINE GF. 5387C 5388 DATA NX,NM,NTS,RX/1,65536,4,1.D-4/ 5389 Z=EL1 5390 ZE=EL2 5391 IF (IJ.EQ.0) ZE=0. 5392 S=ZE-Z 5393 FNM=NM 5394 EP=S/(10.*FNM) 5395 ZEND=ZE-EP 5396 SGR=0. 5397 SGI=0. 5398 NS=NX 5399 NT=0 5400 CALL GF (Z,G1R,G1I) 54011 FNS=NS 5402 DZ=S/FNS 5403 ZP=Z+DZ 5404 IF (ZP-ZE) 3,3,2 54052 DZ=ZE-Z 5406 IF (ABS(DZ)-EP) 17,17,3 54073 DZOT=DZ*.5 5408 ZP=Z+DZOT 5409 CALL GF (ZP,G3R,G3I) 5410 ZP=Z+DZ 5411 CALL GF (ZP,G5R,G5I) 54124 T00R=(G1R+G5R)*DZOT 5413 T00I=(G1I+G5I)*DZOT 5414 T01R=(T00R+DZ*G3R)*0.5 5415 T01I=(T00I+DZ*G3I)*0.5 5416 T10R=(4.0*T01R-T00R)/3.0 5417 T10I=(4.0*T01I-T00I)/3.0 5418C 5419C TEST CONVERGENCE OF 3 POINT ROMBERG RESULT. 5420C 5421 CALL TEST (T01R,T10R,TE1R,T01I,T10I,TE1I,0.D0) 5422 IF (TE1I-RX) 5,5,6 54235 IF (TE1R-RX) 8,8,6 54246 ZP=Z+DZ*0.25 5425 CALL GF (ZP,G2R,G2I) 5426 ZP=Z+DZ*0.75 5427 CALL GF (ZP,G4R,G4I) 5428 T02R=(T01R+DZOT*(G2R+G4R))*0.5 5429 T02I=(T01I+DZOT*(G2I+G4I))*0.5 5430 T11R=(4.0*T02R-T01R)/3.0 5431 T11I=(4.0*T02I-T01I)/3.0 5432 T20R=(16.0*T11R-T10R)/15.0 5433 T20I=(16.0*T11I-T10I)/15.0 5434C 5435C TEST CONVERGENCE OF 5 POINT ROMBERG RESULT. 5436C 5437 CALL TEST (T11R,T20R,TE2R,T11I,T20I,TE2I,0.D0) 5438 IF (TE2I-RX) 7,7,14 54397 IF (TE2R-RX) 9,9,14 54408 SGR=SGR+T10R 5441 SGI=SGI+T10I 5442 NT=NT+2 5443 GO TO 10 54449 SGR=SGR+T20R 5445 SGI=SGI+T20I 5446 NT=NT+1 544710 Z=Z+DZ 5448 IF (Z-ZEND) 11,17,17 544911 G1R=G5R 5450 G1I=G5I 5451 IF (NT-NTS) 1,12,12 545212 IF (NS-NX) 1,1,13 5453C 5454C DOUBLE STEP SIZE 5455C 545613 NS=NS/2 5457 NT=1 5458 GO TO 1 545914 NT=0 5460 IF (NS-NM) 16,15,15 546115 WRITE(3,20) Z 5462 GO TO 9 5463C 5464C HALVE STEP SIZE 5465C 546616 NS=NS*2 5467 FNS=NS 5468 DZ=S/FNS 5469 DZOT=DZ*0.5 5470 G5R=G3R 5471 G5I=G3I 5472 G3R=G2R 5473 G3I=G2I 5474 GO TO 4 547517 CONTINUE 5476 IF (IJ) 19,18,19 5477C 5478C ADD CONTRIBUTION OF NEAR SINGULARITY FOR DIAGONAL TERM 5479C 548018 SGR=2.*(SGR+LOG((SQRT(B*B+S*S)+S)/B)) 5481 SGI=2.*SGI 548219 CONTINUE 5483 RETURN 5484C 548520 FORMAT (24H STEP SIZE LIMITED AT Z=,F10.5) 5486 END 5487 FUNCTION ISEGNO (ITAGI,MX) 5488C *** 5489C DOUBLE PRECISION 6/4/85 5490C 5491 PARAMETER (MAXSEG=1500, MAXMAT=1500) 5492 IMPLICIT REAL*8(A-H,O-Z) 5493C *** 5494C 5495C ISEGNO RETURNS THE SEGMENT NUMBER OF THE MTH SEGMENT HAVING THE 5496C TAG NUMBER ITAGI. IF ITAGI=0 SEGMENT NUMBER M IS RETURNED. 5497C 5498 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 5499 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 5500 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 5501 IF (MX.GT.0) GO TO 1 5502 WRITE(3,6) 5503 STOP 55041 ICNT=0 5505 IF (ITAGI.NE.0) GO TO 2 5506 ISEGNO=MX 5507 RETURN 55082 IF (N.LT.1) GO TO 4 5509 DO 3 I=1,N 5510 IF (ITAG(I).NE.ITAGI) GO TO 3 5511 ICNT=ICNT+1 5512 IF (ICNT.EQ.MX) GO TO 5 55133 CONTINUE 55144 WRITE(3,7) ITAGI 5515 STOP 55165 ISEGNO=I 5517 RETURN 5518C 55196 FORMAT (4X,91HCHECK DATA, PARAMETER SPECIFYING SEGMENT POSITION IN 5520 1 A GROUP OF EQUAL TAGS MUST NOT BE ZERO) 55217 FORMAT (///,10X,26HNO SEGMENT HAS AN ITAG OF ,I5) 5522 END 5523 SUBROUTINE LFACTR (A,NROW,IX1,IX2,IP) 5524C *** 5525C DOUBLE PRECISION 6/4/85 5526C 5527 PARAMETER (MAXSEG=1500, MAXMAT=1500) 5528 IMPLICIT REAL*8(A-H,O-Z) 5529C *** 5530C 5531C LFACTR PERFORMS GAUSS-DOOLITTLE MANIPULATIONS ON THE TWO BLOCKS OF 5532C THE TRANSPOSED MATRIX IN CORE STORAGE. THE GAUSS-DOOLITTLE 5533C ALGORITHM IS PRESENTED ON PAGES 411-416 OF A. RALSTON -- A FIRST 5534C COURSE IN NUMERICAL ANALYSIS. COMMENTS BELOW REFER TO COMMENTS IN 5535C RALSTONS TEXT. 5536C 5537 COMPLEX*16 A,D,AJR 5538 INTEGER R,R1,R2,PJ,PR 5539 LOGICAL L1,L2,L3 5540 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 5541 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 5542 COMMON /SCRATM/ D(2*MAXSEG) 5543 DIMENSION A(NROW,1), IP(NROW) 5544 IFLG=0 5545C 5546C INITIALIZE R1,R2,J1,J2 5547C 5548 L1=IX1.EQ.1.AND.IX2.EQ.2 5549 L2=(IX2-1).EQ.IX1 5550 L3=IX2.EQ.NBLSYM 5551 IF (L1) GO TO 1 5552 GO TO 2 55531 R1=1 5554 R2=2*NPSYM 5555 J1=1 5556 J2=-1 5557 GO TO 5 55582 R1=NPSYM+1 5559 R2=2*NPSYM 5560 J1=(IX1-1)*NPSYM+1 5561 IF (L2) GO TO 3 5562 GO TO 4 55633 J2=J1+NPSYM-2 5564 GO TO 5 55654 J2=J1+NPSYM-1 55665 IF (L3) R2=NPSYM+NLSYM 5567 DO 16 R=R1,R2 5568C 5569C STEP 1 5570C 5571 DO 6 K=J1,NROW 5572 D(K)=A(K,R) 55736 CONTINUE 5574C 5575C STEPS 2 AND 3 5576C 5577 IF (L1.OR.L2) J2=J2+1 5578 IF (J1.GT.J2) GO TO 9 5579 IXJ=0 5580 DO 8 J=J1,J2 5581 IXJ=IXJ+1 5582 PJ=IP(J) 5583 AJR=D(PJ) 5584 A(J,R)=AJR 5585 D(PJ)=D(J) 5586 JP1=J+1 5587 DO 7 I=JP1,NROW 5588 D(I)=D(I)-A(I,IXJ)*AJR 55897 CONTINUE 55908 CONTINUE 55919 CONTINUE 5592C 5593C STEP 4 5594C 5595 J2P1=J2+1 5596 IF (L1.OR.L2) GO TO 11 5597 IF (NROW.LT.J2P1) GO TO 16 5598 DO 10 I=J2P1,NROW 5599 A(I,R)=D(I) 560010 CONTINUE 5601 GO TO 16 560211 DMAX=DREAL(D(J2P1)*DCONJG(D(J2P1))) 5603 IP(J2P1)=J2P1 5604 J2P2=J2+2 5605 IF (J2P2.GT.NROW) GO TO 13 5606 DO 12 I=J2P2,NROW 5607 ELMAG=DREAL(D(I)*DCONJG(D(I))) 5608 IF (ELMAG.LT.DMAX) GO TO 12 5609 DMAX=ELMAG 5610 IP(J2P1)=I 561112 CONTINUE 561213 CONTINUE 5613 IF (DMAX.LT.1.D-10) IFLG=1 5614 PR=IP(J2P1) 5615 A(J2P1,R)=D(PR) 5616 D(PR)=D(J2P1) 5617C 5618C STEP 5 5619C 5620 IF (J2P2.GT.NROW) GO TO 15 5621 AJR=1./A(J2P1,R) 5622 DO 14 I=J2P2,NROW 5623 A(I,R)=D(I)*AJR 562414 CONTINUE 562515 CONTINUE 5626 IF (IFLG.EQ.0) GO TO 16 5627 WRITE(3,17) J2,DMAX 5628 IFLG=0 562916 CONTINUE 5630 RETURN 5631C 563217 FORMAT (1H ,6HPIVOT(,I3,2H)=,1P,E16.8) 5633 END 5634 SUBROUTINE LOAD (LDTYP,LDTAG,LDTAGF,LDTAGT,ZLR,ZLI,ZLC) 5635C *** 5636C DOUBLE PRECISION 6/4/85 5637C 5638 PARAMETER (MAXSEG=1500, MAXMAT=1500) 5639 IMPLICIT REAL*8(A-H,O-Z) 5640C *** 5641C 5642C LOAD CALCULATES THE IMPEDANCE OF SPECIFIED SEGMENTS FOR VARIOUS 5643C TYPES OF LOADING 5644C 5645 COMPLEX*16 ZARRAY,ZT,TPCJ,ZINT 5646 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 5647 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 5648 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 5649 COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF 5650 DIMENSION LDTYP(1), LDTAG(1), LDTAGF(1), LDTAGT(1), ZLR(1), ZLI(1) 5651 1, ZLC(1), TPCJX(2) 5652 EQUIVALENCE (TPCJ,TPCJX) 5653 DATA TPCJX/0.,1.883698955D+9/ 5654C 5655C WRITE(3,HEADING) 5656C 5657 WRITE(3,25) 5658C 5659C INITIALIZE D ARRAY, USED FOR TEMPORARY STORAGE OF LOADING 5660C INFORMATION. 5661C 5662 DO 1 I=N2,N 5663 1 ZARRAY(I)=(0.,0.) 5664 IWARN=0 5665C 5666C CYCLE OVER LOADING CARDS 5667C 5668 ISTEP=0 5669 2 ISTEP=ISTEP+1 5670 IF (ISTEP.LE.NLOAD) GO TO 5 5671 IF (IWARN.EQ.1) WRITE(3,26) 5672 IF (N1+2*M1.GT.0) GO TO 4 5673 NOP=N/NP 5674 IF (NOP.EQ.1) GO TO 4 5675 DO 3 I=1,NP 5676 ZT=ZARRAY(I) 5677 L1=I 5678 DO 3 L2=2,NOP 5679 L1=L1+NP 5680 3 ZARRAY(L1)=ZT 5681 4 RETURN 5682 5 IF (LDTYP(ISTEP).LE.5) GO TO 6 5683 WRITE(3,27) LDTYP(ISTEP) 5684 STOP 5685 6 LDTAGS=LDTAG(ISTEP) 5686 JUMP=LDTYP(ISTEP)+1 5687 ICHK=0 5688C 5689C SEARCH SEGMENTS FOR PROPER ITAGS 5690C 5691 L1=N2 5692 L2=N 5693 IF (LDTAGS.NE.0) GO TO 7 5694 IF (LDTAGF(ISTEP).EQ.0.AND.LDTAGT(ISTEP).EQ.0) GO TO 7 5695 L1=LDTAGF(ISTEP) 5696 L2=LDTAGT(ISTEP) 5697 IF (L1.GT.N1) GO TO 7 5698 WRITE(3,29) 5699 STOP 5700 7 DO 17 I=L1,L2 5701 IF (LDTAGS.EQ.0) GO TO 8 5702 IF (LDTAGS.NE.ITAG(I)) GO TO 17 5703 IF (LDTAGF(ISTEP).EQ.0) GO TO 8 5704 ICHK=ICHK+1 5705 IF (ICHK.GE.LDTAGF(ISTEP).AND.ICHK.LE.LDTAGT(ISTEP)) GO TO 9 5706 GO TO 17 5707 8 ICHK=1 5708C 5709C CALCULATION OF LAMDA*IMPED. PER UNIT LENGTH, JUMP TO APPROPRIATE 5710C SECTION FOR LOADING TYPE 5711C 5712 9 GO TO (10,11,12,13,14,15), JUMP 5713 10 ZT=ZLR(ISTEP)/SI(I)+TPCJ*ZLI(ISTEP)/(SI(I)*WLAM) 5714 IF (ABS(ZLC(ISTEP)).GT.1.D-20) ZT=ZT+WLAM/(TPCJ*SI(I)*ZLC(ISTEP)) 5715 GO TO 16 5716 11 ZT=TPCJ*SI(I)*ZLC(ISTEP)/WLAM 5717 IF (ABS(ZLI(ISTEP)).GT.1.D-20) ZT=ZT+SI(I)*WLAM/(TPCJ*ZLI(ISTEP)) 5718 IF (ABS(ZLR(ISTEP)).GT.1.D-20) ZT=ZT+SI(I)/ZLR(ISTEP) 5719 ZT=1./ZT 5720 GO TO 16 5721 12 ZT=ZLR(ISTEP)*WLAM+TPCJ*ZLI(ISTEP) 5722 IF (ABS(ZLC(ISTEP)).GT.1.D-20) ZT=ZT+1./(TPCJ*SI(I)*SI(I)*ZLC(ISTE 5723 1P)) 5724 GO TO 16 5725 13 ZT=TPCJ*SI(I)*SI(I)*ZLC(ISTEP) 5726 IF (ABS(ZLI(ISTEP)).GT.1.D-20) ZT=ZT+1./(TPCJ*ZLI(ISTEP)) 5727 IF (ABS(ZLR(ISTEP)).GT.1.D-20) ZT=ZT+1./(ZLR(ISTEP)*WLAM) 5728 ZT=1./ZT 5729 GO TO 16 5730 14 ZT=DCMPLX(ZLR(ISTEP),ZLI(ISTEP))/SI(I) 5731 GO TO 16 5732 15 ZT=ZINT(ZLR(ISTEP)*WLAM,BI(I)) 5733 16 IF ((ABS(DREAL(ZARRAY(I)))+ABS(DIMAG(ZARRAY(I)))).GT.1.D-20) 5734 1IWARN=1 5735 ZARRAY(I)=ZARRAY(I)+ZT 5736 17 CONTINUE 5737 IF (ICHK.NE.0) GO TO 18 5738 WRITE(3,28) LDTAGS 5739 STOP 5740C 5741C PRINTING THE SEGMENT LOADING DATA, JUMP TO PROPER PRINT 5742C 5743 18 GO TO (19,20,21,22,23,24), JUMP 5744 19 CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),ZLR(ISTEP),ZLI(ISTEP 5745 1),ZLC(ISTEP),0.D0,0.D0,0.D0,' SERIES ') 5746 GO TO 2 5747 20 CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),ZLR(ISTEP),ZLI(ISTEP 5748 1),ZLC(ISTEP),0.D0,0.D0,0.D0,'PARALLEL') 5749 GO TO 2 5750 21 CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),ZLR(ISTEP),ZLI(ISTEP 5751 1),ZLC(ISTEP),0.D0,0.D0,0.D0,' SERIES (PER METER) ') 5752 GO TO 2 5753 22 CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),ZLR(ISTEP),ZLI(ISTEP 5754 1),ZLC(ISTEP),0.D0,0.D0,0.D0,'PARALLEL (PER METER)') 5755 GO TO 2 5756 23 CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),0.D0,0.D0,0.D0, 5757 &ZLR(ISTEP),ZLI(ISTEP),0.D0,'FIXED IMPEDANCE ') 5758 GO TO 2 5759 24 CALL PRNT (LDTAGS,LDTAGF(ISTEP),LDTAGT(ISTEP),0.D0,0.D0,0.D0,0.D0, 5760 &0.D0,ZLR(ISTEP),' WIRE ') 5761 GO TO 2 5762C 5763 25 FORMAT (//,7X,8HLOCATION,10X,10HRESISTANCE,3X,10HINDUCTANCE,2X,11H 5764 1CAPACITANCE,7X,16HIMPEDANCE (OHMS),5X,12HCONDUCTIVITY,4X,4HTYPE,/, 5765 24X,4HITAG,10H FROM THRU,10X,4HOHMS,8X,6HHENRYS,7X,6HFARADS,8X,4HRE 5766 3AL,6X,9HIMAGINARY,4X,10HMHOS/METER) 5767 26 FORMAT (/,10X,74HNOTE, SOME OF THE ABOVE SEGMENTS HAVE BEEN LOADED 5768 1 TWICE - IMPEDANCES ADDED) 5769 27 FORMAT (/,10X,46HIMPROPER LOAD TYPE CHOOSEN, REQUESTED TYPE IS ,I3 5770 1) 5771 28 FORMAT (/,10X,50HLOADING DATA CARD ERROR, NO SEGMENT HAS AN ITAG = 5772 1 ,I5) 5773 29 FORMAT (63H ERROR - LOADING MAY NOT BE ADDED TO SEGMENTS IN N.G.F. 5774 1 SECTION) 5775 END 5776 SUBROUTINE LTSOLV (A,NROW,IX,B,NEQ,NRH,IFL1,IFL2) 5777C *** 5778C DOUBLE PRECISION 6/4/85 5779C 5780 PARAMETER (MAXSEG=1500, MAXMAT=1500) 5781 IMPLICIT REAL*8(A-H,O-Z) 5782C *** 5783C 5784C LTSOLV SOLVES THE MATRIX EQ. Y(R)*LU(T)=B(R) WHERE (R) DENOTES ROW 5785C VECTOR AND LU(T) DENOTES THE LU DECOMPOSITION OF THE TRANSPOSE OF 5786C THE ORIGINAL COEFFICIENT MATRIX. THE LU(T) DECOMPOSITION IS 5787C STORED ON TAPE 5 IN BLOCKS IN ASCENDING ORDER AND ON FILE 3 IN 5788C BLOCKS OF DESCENDING ORDER. 5789C 5790 COMPLEX*16 A,B,Y,SUM 5791 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 5792 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 5793 COMMON /SCRATM/ Y(2*MAXSEG) 5794 DIMENSION A(NROW,NROW), B(NEQ,NRH), IX(NEQ) 5795C 5796C FORWARD SUBSTITUTION 5797C 5798 I2=2*NPSYM*NROW 5799 DO 4 IXBLK1=1,NBLSYM 5800 CALL BLCKIN (A,IFL1,1,I2,1,121) 5801 K2=NPSYM 5802 IF (IXBLK1.EQ.NBLSYM) K2=NLSYM 5803 JST=(IXBLK1-1)*NPSYM 5804 DO 4 IC=1,NRH 5805 J=JST 5806 DO 3 K=1,K2 5807 JM1=J 5808 J=J+1 5809 SUM=(0.,0.) 5810 IF (JM1.LT.1) GO TO 2 5811 DO 1 I=1,JM1 58121 SUM=SUM+A(I,K)*B(I,IC) 58132 B(J,IC)=(B(J,IC)-SUM)/A(J,K) 58143 CONTINUE 58154 CONTINUE 5816C 5817C BACKWARD SUBSTITUTION 5818C 5819 JST=NROW+1 5820 DO 8 IXBLK1=1,NBLSYM 5821 CALL BLCKIN (A,IFL2,1,I2,1,122) 5822 K2=NPSYM 5823 IF (IXBLK1.EQ.1) K2=NLSYM 5824 DO 7 IC=1,NRH 5825 KP=K2+1 5826 J=JST 5827 DO 6 K=1,K2 5828 KP=KP-1 5829 JP1=J 5830 J=J-1 5831 SUM=(0.,0.) 5832 IF (NROW.LT.JP1) GO TO 6 5833 DO 5 I=JP1,NROW 58345 SUM=SUM+A(I,KP)*B(I,IC) 5835 B(J,IC)=B(J,IC)-SUM 58366 CONTINUE 58377 CONTINUE 58388 JST=JST-K2 5839C 5840C UNSCRAMBLE SOLUTION 5841C 5842 DO 10 IC=1,NRH 5843 DO 9 I=1,NROW 5844 IXI=IX(I) 58459 Y(IXI)=B(I,IC) 5846 DO 10 I=1,NROW 584710 B(I,IC)=Y(I) 5848 RETURN 5849 END 5850 SUBROUTINE LUNSCR (A,NROW,NOP,IX,IP,IU2,IU3,IU4) 5851C *** 5852C DOUBLE PRECISION 6/4/85 5853C 5854 IMPLICIT REAL*8(A-H,O-Z) 5855C *** 5856C 5857C S/R WHICH UNSCRAMBLES, SCRAMBLED FACTORED MATRIX 5858C 5859 COMPLEX*16 A,TEMP 5860 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 5861 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 5862 DIMENSION A(NROW,1), IP(NROW), IX(NROW) 5863 I1=1 5864 I2=2*NPSYM*NROW 5865 NM1=NROW-1 5866 REWIND IU2 5867 REWIND IU3 5868 REWIND IU4 5869 DO 9 KK=1,NOP 5870 KA=(KK-1)*NROW 5871 DO 4 IXBLK1=1,NBLSYM 5872 CALL BLCKIN (A,IU2,I1,I2,1,121) 5873 K1=(IXBLK1-1)*NPSYM+2 5874 IF (NM1.LT.K1) GO TO 3 5875 J2=0 5876 DO 2 K=K1,NM1 5877 IF (J2.LT.NPSYM) J2=J2+1 5878 IPK=IP(K+KA) 5879 DO 1 J=1,J2 5880 TEMP=A(K,J) 5881 A(K,J)=A(IPK,J) 5882 A(IPK,J)=TEMP 58831 CONTINUE 58842 CONTINUE 58853 CONTINUE 5886 CALL BLCKOT (A,IU3,I1,I2,1,122) 58874 CONTINUE 5888 DO 5 IXBLK1=1,NBLSYM 5889 BACKSPACE IU3 5890 IF (IXBLK1.NE.1) BACKSPACE IU3 5891 CALL BLCKIN (A,IU3,I1,I2,1,123) 5892 CALL BLCKOT (A,IU4,I1,I2,1,124) 58935 CONTINUE 5894 DO 6 I=1,NROW 5895 IX(I+KA)=I 58966 CONTINUE 5897 DO 7 I=1,NROW 5898 IPI=IP(I+KA) 5899 IXT=IX(I+KA) 5900 IX(I+KA)=IX(IPI+KA) 5901 IX(IPI+KA)=IXT 59027 CONTINUE 5903 IF (NOP.EQ.1) GO TO 9 5904 NB1=NBLSYM-1 5905C SKIP NB1 LOGICAL RECORDS FORWARD 5906 DO 8 IXBLK1=1,NB1 5907 CALL BLCKIN (A,IU3,I1,I2,1,125) 59088 CONTINUE 59099 CONTINUE 5910 REWIND IU2 5911 REWIND IU3 5912 REWIND IU4 5913 RETURN 5914 END 5915 SUBROUTINE MOVE (ROX,ROY,ROZ,XS,YS,ZS,ITS,NRPT,ITGI) 5916C *** 5917C DOUBLE PRECISION 6/4/85 5918C 5919 PARAMETER (MAXSEG=1500, MAXMAT=1500) 5920 IMPLICIT REAL*8(A-H,O-Z) 5921C *** 5922C 5923C SUBROUTINE MOVE MOVES THE STRUCTURE WITH RESPECT TO ITS 5924C COORDINATE SYSTEM OR REPRODUCES STRUCTURE IN NEW POSITIONS. 5925C STRUCTURE IS ROTATED ABOUT X,Y,Z AXES BY ROX,ROY,ROZ 5926C RESPECTIVELY, THEN SHIFTED BY XS,YS,ZS 5927C 5928 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 5929 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 5930 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 5931 COMMON /ANGL/ SALP(MAXSEG) 5932 DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), X2(1), Y 5933 12(1), Z2(1) 5934 EQUIVALENCE (X2(1),SI(1)), (Y2(1),ALP(1)), (Z2(1),BET(1)) 5935 EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON 5936 12), (T2Z,ITAG) 5937 IF (ABS(ROX)+ABS(ROY).GT.1.D-10) IPSYM=IPSYM*3 5938 SPS=SIN(ROX) 5939 CPS=COS(ROX) 5940 STH=SIN(ROY) 5941 CTH=COS(ROY) 5942 SPH=SIN(ROZ) 5943 CPH=COS(ROZ) 5944 XX=CPH*CTH 5945 XY=CPH*STH*SPS-SPH*CPS 5946 XZ=CPH*STH*CPS+SPH*SPS 5947 YX=SPH*CTH 5948 YY=SPH*STH*SPS+CPH*CPS 5949 YZ=SPH*STH*CPS-CPH*SPS 5950 ZX=-STH 5951 ZY=CTH*SPS 5952 ZZ=CTH*CPS 5953 NRP=NRPT 5954 IF (NRPT.EQ.0) NRP=1 5955 IX=1 5956 IF (N.LT.N2) GO TO 3 5957 I1=ISEGNO(ITS,1) 5958 IF (I1.LT.N2) I1=N2 5959 IX=I1 5960 K=N 5961 IF (NRPT.EQ.0) K=I1-1 5962 DO 2 IR=1,NRP 5963 DO 1 I=I1,N 5964 K=K+1 5965 XI=X(I) 5966 YI=Y(I) 5967 ZI=Z(I) 5968 X(K)=XI*XX+YI*XY+ZI*XZ+XS 5969 Y(K)=XI*YX+YI*YY+ZI*YZ+YS 5970 Z(K)=XI*ZX+YI*ZY+ZI*ZZ+ZS 5971 XI=X2(I) 5972 YI=Y2(I) 5973 ZI=Z2(I) 5974 X2(K)=XI*XX+YI*XY+ZI*XZ+XS 5975 Y2(K)=XI*YX+YI*YY+ZI*YZ+YS 5976 Z2(K)=XI*ZX+YI*ZY+ZI*ZZ+ZS 5977 BI(K)=BI(I) 5978 ITAG(K)=ITAG(I) 5979 IF(ITAG(I).NE.0)ITAG(K)=ITAG(I)+ITGI 59801 CONTINUE 5981 I1=N+1 5982 N=K 59832 CONTINUE 59843 IF (M.LT.M2) GO TO 6 5985 I1=M2 5986 K=M 5987 LDI=LD+1 5988 IF (NRPT.EQ.0) K=M1 5989 DO 5 II=1,NRP 5990 DO 4 I=I1,M 5991 K=K+1 5992 IR=LDI-I 5993 KR=LDI-K 5994 XI=X(IR) 5995 YI=Y(IR) 5996 ZI=Z(IR) 5997 X(KR)=XI*XX+YI*XY+ZI*XZ+XS 5998 Y(KR)=XI*YX+YI*YY+ZI*YZ+YS 5999 Z(KR)=XI*ZX+YI*ZY+ZI*ZZ+ZS 6000 XI=T1X(IR) 6001 YI=T1Y(IR) 6002 ZI=T1Z(IR) 6003 T1X(KR)=XI*XX+YI*XY+ZI*XZ 6004 T1Y(KR)=XI*YX+YI*YY+ZI*YZ 6005 T1Z(KR)=XI*ZX+YI*ZY+ZI*ZZ 6006 XI=T2X(IR) 6007 YI=T2Y(IR) 6008 ZI=T2Z(IR) 6009 T2X(KR)=XI*XX+YI*XY+ZI*XZ 6010 T2Y(KR)=XI*YX+YI*YY+ZI*YZ 6011 T2Z(KR)=XI*ZX+YI*ZY+ZI*ZZ 6012 SALP(KR)=SALP(IR) 60134 BI(KR)=BI(IR) 6014 I1=M+1 60155 M=K 60166 IF ((NRPT.EQ.0).AND.(IX.EQ.1)) RETURN 6017 NP=N 6018 MP=M 6019 IPSYM=0 6020 RETURN 6021 END 6022 6023 SUBROUTINE NEFLD (XOB,YOB,ZOB,EX,EY,EZ) 6024C *** 6025C DOUBLE PRECISION 6/4/85 6026C 6027 PARAMETER (MAXSEG=1500, MAXMAT=1500) 6028 IMPLICIT REAL*8(A-H,O-Z) 6029C *** 6030C 6031C NEFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER 6032C THE STRUCTURE CURRENTS HAVE BEEN COMPUTED. 6033C 6034 COMPLEX*16 EX,EY,EZ,CUR,ACX,BCX,CCX,EXK,EYK,EZK,EXS,EYS,EZS,EXC 6035 1,EYC,EZC,ZRATI,ZRATI2,T1,FRATI 6036 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 6037 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 6038 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 6039 COMMON /ANGL/ SALP(MAXSEG) 6040 COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG), 6041 &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG) 6042 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 6043 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 6044 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 6045 &KSYMP,IFAR,IPERF 6046 DIMENSION CAB(1), SAB(1), T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), 6047 1T2Z(1) 6048 EQUIVALENCE (CAB,ALP), (SAB,BET) 6049 EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON 6050 12), (T2Z,ITAG) 6051 EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y 6052 1J,IND1), (T2ZJ,IND2) 6053 EX=(0.,0.) 6054 EY=(0.,0.) 6055 EZ=(0.,0.) 6056 AX=0. 6057 IF (N.EQ.0) GO TO 20 6058 DO 1 I=1,N 6059 XJ=XOB-X(I) 6060 YJ=YOB-Y(I) 6061 ZJ=ZOB-Z(I) 6062 ZP=CAB(I)*XJ+SAB(I)*YJ+SALP(I)*ZJ 6063 IF (ABS(ZP).GT.0.5001*SI(I)) GO TO 1 6064 ZP=XJ*XJ+YJ*YJ+ZJ*ZJ-ZP*ZP 6065 XJ=BI(I) 6066 IF (ZP.GT.0.9*XJ*XJ) GO TO 1 6067 AX=XJ 6068 GO TO 2 60691 CONTINUE 60702 DO 19 I=1,N 6071 S=SI(I) 6072 B=BI(I) 6073 XJ=X(I) 6074 YJ=Y(I) 6075 ZJ=Z(I) 6076 CABJ=CAB(I) 6077 SABJ=SAB(I) 6078 SALPJ=SALP(I) 6079 IF (IEXK.EQ.0) GO TO 18 6080 IPR=ICON1(I) 6081 IF (IPR) 3,8,4 60823 IPR=-IPR 6083 IF (-ICON1(IPR).NE.I) GO TO 9 6084 GO TO 6 60854 IF (IPR.NE.I) GO TO 5 6086 IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 9 6087 GO TO 7 60885 IF (ICON2(IPR).NE.I) GO TO 9 60896 XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR)) 6090 IF (XI.LT.0.999999D+0) GO TO 9 6091 IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 9 60927 IND1=0 6093 GO TO 10 60948 IND1=1 6095 GO TO 10 60969 IND1=2 609710 IPR=ICON2(I) 6098 IF (IPR) 11,16,12 609911 IPR=-IPR 6100 IF (-ICON2(IPR).NE.I) GO TO 17 6101 GO TO 14 610212 IF (IPR.NE.I) GO TO 13 6103 IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 17 6104 GO TO 15 610513 IF (ICON1(IPR).NE.I) GO TO 17 610614 XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR)) 6107 IF (XI.LT.0.999999D+0) GO TO 17 6108 IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 17 610915 IND2=0 6110 GO TO 18 611116 IND2=1 6112 GO TO 18 611317 IND2=2 611418 CONTINUE 6115 CALL EFLD (XOB,YOB,ZOB,AX,1) 6116 ACX=DCMPLX(AIR(I),AII(I)) 6117 BCX=DCMPLX(BIR(I),BII(I)) 6118 CCX=DCMPLX(CIR(I),CII(I)) 6119 EX=EX+EXK*ACX+EXS*BCX+EXC*CCX 6120 EY=EY+EYK*ACX+EYS*BCX+EYC*CCX 612119 EZ=EZ+EZK*ACX+EZS*BCX+EZC*CCX 6122 IF (M.EQ.0) RETURN 612320 JC=N 6124 JL=LD+1 6125 DO 21 I=1,M 6126 JL=JL-1 6127 S=BI(JL) 6128 XJ=X(JL) 6129 YJ=Y(JL) 6130 ZJ=Z(JL) 6131 T1XJ=T1X(JL) 6132 T1YJ=T1Y(JL) 6133 T1ZJ=T1Z(JL) 6134 T2XJ=T2X(JL) 6135 T2YJ=T2Y(JL) 6136 T2ZJ=T2Z(JL) 6137 JC=JC+3 6138 ACX=T1XJ*CUR(JC-2)+T1YJ*CUR(JC-1)+T1ZJ*CUR(JC) 6139 BCX=T2XJ*CUR(JC-2)+T2YJ*CUR(JC-1)+T2ZJ*CUR(JC) 6140 DO 21 IP=1,KSYMP 6141 IPGND=IP 6142 CALL UNERE (XOB,YOB,ZOB) 6143 EX=EX+ACX*EXK+BCX*EXS 6144 EY=EY+ACX*EYK+BCX*EYS 614521 EZ=EZ+ACX*EZK+BCX*EZS 6146 RETURN 6147 END 6148 SUBROUTINE NETWK (CM,CMB,CMC,CMD,IP,EINC) 6149C *** 6150C DOUBLE PRECISION 6/4/85 6151C 6152 PARAMETER (MAXSEG=1500, MAXMAT=1500) 6153 IMPLICIT REAL*8(A-H,O-Z) 6154C *** 6155C 6156C SUBROUTINE NETWK SOLVES FOR STRUCTURE CURRENTS FOR A GIVEN 6157C EXCITATION INCLUDING THE EFFECT OF NON-RADIATING NETWORKS IF 6158C PRESENT. 6159C 6160 COMPLEX*16 CMN,RHNT,YMIT,RHS,ZPED,EINC,VSANT,VLT,CUR,VSRC,RHNX 6161 1,VQD,VQDS,CUX,CM,CMB,CMC,CMD 6162 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 6163 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 6164 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 6165 COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG), 6166 &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG) 6167 COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS( 6168 130),NVQD,NSANT,NQDS 6169 COMMON/NETCX/ZPED,PIN,PNLS,X11R(30),X11I(30),X12R(30),X12I(30), 6170 &X22R(30),X22I(30),NTYP(30),ISEG1(30),ISEG2(30),NEQ,NPEQ,NEQ2, 6171 &NONET,NTSOL,NPRINT,MASYM 6172 DIMENSION EINC(1), IP(1),CM(1),CMB(1),CMC(1),CMD(1) 6173 DIMENSION CMN(30,30), RHNT(30), IPNT(30), NTEQA(30), NTSCA(30), 6174 &RHS(3*MAXSEG), VSRC(30), RHNX(30) 6175 DATA NDIMN,NDIMNP/30,31/,TP/6.283185308D+0/ 6176 NEQZ2=NEQ2 6177 IF(NEQZ2.EQ.0)NEQZ2=1 6178 PIN=0. 6179 PNLS=0. 6180 NEQT=NEQ+NEQ2 6181 IF (NTSOL.NE.0) GO TO 42 6182 NOP=NEQ/NPEQ 6183 IF (MASYM.EQ.0) GO TO 14 6184C 6185C COMPUTE RELATIVE MATRIX ASYMMETRY 6186C 6187 IROW1=0 6188 IF (NONET.EQ.0) GO TO 5 6189 DO 4 I=1,NONET 6190 NSEG1=ISEG1(I) 6191 DO 3 ISC1=1,2 6192 IF (IROW1.EQ.0) GO TO 2 6193 DO 1 J=1,IROW1 6194 IF (NSEG1.EQ.IPNT(J)) GO TO 3 61951 CONTINUE 61962 IROW1=IROW1+1 6197 IPNT(IROW1)=NSEG1 61983 NSEG1=ISEG2(I) 61994 CONTINUE 62005 IF (NSANT.EQ.0) GO TO 9 6201 DO 8 I=1,NSANT 6202 NSEG1=ISANT(I) 6203 IF (IROW1.EQ.0) GO TO 7 6204 DO 6 J=1,IROW1 6205 IF (NSEG1.EQ.IPNT(J)) GO TO 8 62066 CONTINUE 62077 IROW1=IROW1+1 6208 IPNT(IROW1)=NSEG1 62098 CONTINUE 62109 IF (IROW1.LT.NDIMNP) GO TO 10 6211 WRITE(3,59) 6212 STOP 621310 IF (IROW1.LT.2) GO TO 14 6214 DO 12 I=1,IROW1 6215 ISC1=IPNT(I) 6216 ASM=SI(ISC1) 6217 DO 11 J=1,NEQT 621811 RHS(J)=(0.,0.) 6219 RHS(ISC1)=(1.,0.) 6220 CALL SOLGF (CM,CMB,CMC,CMD,RHS,IP,NP,N1,N,MP,M1,M,NEQ,NEQ2,NEQZ2) 6221 CALL CABC (RHS) 6222 DO 12 J=1,IROW1 6223 ISC1=IPNT(J) 622412 CMN(J,I)=RHS(ISC1)/ASM 6225 ASM=0. 6226 ASA=0. 6227 DO 13 I=2,IROW1 6228 ISC1=I-1 6229 DO 13 J=1,ISC1 6230 CUX=CMN(I,J) 6231 PWR=ABS((CUX-CMN(J,I))/CUX) 6232 ASA=ASA+PWR*PWR 6233 IF (PWR.LT.ASM) GO TO 13 6234 ASM=PWR 6235 NTEQ=IPNT(I) 6236 NTSC=IPNT(J) 623713 CONTINUE 6238 ASA=SQRT(ASA*2./DFLOAT(IROW1*(IROW1-1))) 6239 WRITE(3,58) ASM,NTEQ,NTSC,ASA 624014 IF (NONET.EQ.0) GO TO 48 6241C 6242C SOLUTION OF NETWORK EQUATIONS 6243C 6244 DO 15 I=1,NDIMN 6245 RHNX(I)=(0.,0.) 6246 DO 15 J=1,NDIMN 624715 CMN(I,J)=(0.,0.) 6248 NTEQ=0 6249 NTSC=0 6250C 6251C SORT NETWORK AND SOURCE DATA AND ASSIGN EQUATION NUMBERS TO 6252C SEGMENTS. 6253C 6254 DO 38 J=1,NONET 6255 NSEG1=ISEG1(J) 6256 NSEG2=ISEG2(J) 6257 IF (NTYP(J).GT.1) GO TO 16 6258 Y11R=X11R(J) 6259 Y11I=X11I(J) 6260 Y12R=X12R(J) 6261 Y12I=X12I(J) 6262 Y22R=X22R(J) 6263 Y22I=X22I(J) 6264 GO TO 17 626516 Y22R=TP*X11I(J)/WLAM 6266 Y12R=0. 6267 Y12I=1./(X11R(J)*SIN(Y22R)) 6268 Y11R=X12R(J) 6269 Y11I=-Y12I*COS(Y22R) 6270 Y22R=X22R(J) 6271 Y22I=Y11I+X22I(J) 6272 Y11I=Y11I+X12I(J) 6273 IF (NTYP(J).EQ.2) GO TO 17 6274 Y12R=-Y12R 6275 Y12I=-Y12I 627617 IF (NSANT.EQ.0) GO TO 19 6277 DO 18 I=1,NSANT 6278 IF (NSEG1.NE.ISANT(I)) GO TO 18 6279 ISC1=I 6280 GO TO 22 628118 CONTINUE 628219 ISC1=0 6283 IF (NTEQ.EQ.0) GO TO 21 6284 DO 20 I=1,NTEQ 6285 IF (NSEG1.NE.NTEQA(I)) GO TO 20 6286 IROW1=I 6287 GO TO 25 628820 CONTINUE 628921 NTEQ=NTEQ+1 6290 IROW1=NTEQ 6291 NTEQA(NTEQ)=NSEG1 6292 GO TO 25 629322 IF (NTSC.EQ.0) GO TO 24 6294 DO 23 I=1,NTSC 6295 IF (NSEG1.NE.NTSCA(I)) GO TO 23 6296 IROW1=NDIMNP-I 6297 GO TO 25 629823 CONTINUE 629924 NTSC=NTSC+1 6300 IROW1=NDIMNP-NTSC 6301 NTSCA(NTSC)=NSEG1 6302 VSRC(NTSC)=VSANT(ISC1) 630325 IF (NSANT.EQ.0) GO TO 27 6304 DO 26 I=1,NSANT 6305 IF (NSEG2.NE.ISANT(I)) GO TO 26 6306 ISC2=I 6307 GO TO 30 630826 CONTINUE 630927 ISC2=0 6310 IF (NTEQ.EQ.0) GO TO 29 6311 DO 28 I=1,NTEQ 6312 IF (NSEG2.NE.NTEQA(I)) GO TO 28 6313 IROW2=I 6314 GO TO 33 631528 CONTINUE 631629 NTEQ=NTEQ+1 6317 IROW2=NTEQ 6318 NTEQA(NTEQ)=NSEG2 6319 GO TO 33 632030 IF (NTSC.EQ.0) GO TO 32 6321 DO 31 I=1,NTSC 6322 IF (NSEG2.NE.NTSCA(I)) GO TO 31 6323 IROW2=NDIMNP-I 6324 GO TO 33 632531 CONTINUE 632632 NTSC=NTSC+1 6327 IROW2=NDIMNP-NTSC 6328 NTSCA(NTSC)=NSEG2 6329 VSRC(NTSC)=VSANT(ISC2) 633033 IF (NTSC+NTEQ.LT.NDIMNP) GO TO 34 6331 WRITE(3,59) 6332 STOP 6333C 6334C FILL NETWORK EQUATION MATRIX AND RIGHT HAND SIDE VECTOR WITH 6335C NETWORK SHORT-CIRCUIT ADMITTANCE MATRIX COEFFICIENTS. 6336C 633734 IF (ISC1.NE.0) GO TO 35 6338 CMN(IROW1,IROW1)=CMN(IROW1,IROW1)-DCMPLX(Y11R,Y11I)*SI(NSEG1) 6339 CMN(IROW1,IROW2)=CMN(IROW1,IROW2)-DCMPLX(Y12R,Y12I)*SI(NSEG1) 6340 GO TO 36 634135 RHNX(IROW1)=RHNX(IROW1)+DCMPLX(Y11R,Y11I)*VSANT(ISC1)/WLAM 6342 RHNX(IROW2)=RHNX(IROW2)+DCMPLX(Y12R,Y12I)*VSANT(ISC1)/WLAM 634336 IF (ISC2.NE.0) GO TO 37 6344 CMN(IROW2,IROW2)=CMN(IROW2,IROW2)-DCMPLX(Y22R,Y22I)*SI(NSEG2) 6345 CMN(IROW2,IROW1)=CMN(IROW2,IROW1)-DCMPLX(Y12R,Y12I)*SI(NSEG2) 6346 GO TO 38 634737 RHNX(IROW1)=RHNX(IROW1)+DCMPLX(Y12R,Y12I)*VSANT(ISC2)/WLAM 6348 RHNX(IROW2)=RHNX(IROW2)+DCMPLX(Y22R,Y22I)*VSANT(ISC2)/WLAM 634938 CONTINUE 6350C 6351C ADD INTERACTION MATRIX ADMITTANCE ELEMENTS TO NETWORK EQUATION 6352C MATRIX 6353C 6354 DO 41 I=1,NTEQ 6355 DO 39 J=1,NEQT 635639 RHS(J)=(0.,0.) 6357 IROW1=NTEQA(I) 6358 RHS(IROW1)=(1.,0.) 6359 CALL SOLGF (CM,CMB,CMC,CMD,RHS,IP,NP,N1,N,MP,M1,M,NEQ,NEQ2,NEQZ2) 6360 CALL CABC (RHS) 6361 DO 40 J=1,NTEQ 6362 IROW1=NTEQA(J) 636340 CMN(I,J)=CMN(I,J)+RHS(IROW1) 636441 CONTINUE 6365C 6366C FACTOR NETWORK EQUATION MATRIX 6367C 6368 CALL FACTR (NTEQ,CMN,IPNT,NDIMN) 6369C 6370C ADD TO NETWORK EQUATION RIGHT HAND SIDE THE TERMS DUE TO ELEMENT 6371C INTERACTIONS 6372C 637342 IF (NONET.EQ.0) GO TO 48 6374 DO 43 I=1,NEQT 637543 RHS(I)=EINC(I) 6376 CALL SOLGF (CM,CMB,CMC,CMD,RHS,IP,NP,N1,N,MP,M1,M,NEQ,NEQ2,NEQZ2) 6377 CALL CABC (RHS) 6378 DO 44 I=1,NTEQ 6379 IROW1=NTEQA(I) 638044 RHNT(I)=RHNX(I)+RHS(IROW1) 6381C 6382C SOLVE NETWORK EQUATIONS 6383C 6384 CALL SOLVE (NTEQ,CMN,IPNT,RHNT,NDIMN) 6385C 6386C ADD FIELDS DUE TO NETWORK VOLTAGES TO ELECTRIC FIELDS APPLIED TO 6387C STRUCTURE AND SOLVE FOR INDUCED CURRENT 6388C 6389 DO 45 I=1,NTEQ 6390 IROW1=NTEQA(I) 639145 EINC(IROW1)=EINC(IROW1)-RHNT(I) 6392 CALL SOLGF (CM,CMB,CMC,CMD,EINC,IP,NP,N1,N,MP,M1,M,NEQ,NEQ2,NEQZ2) 6393 CALL CABC (EINC) 6394 IF (NPRINT.EQ.0) WRITE(3,61) 6395 IF (NPRINT.EQ.0) WRITE(3,60) 6396 DO 46 I=1,NTEQ 6397 IROW1=NTEQA(I) 6398 VLT=RHNT(I)*SI(IROW1)*WLAM 6399 CUX=EINC(IROW1)*WLAM 6400 YMIT=CUX/VLT 6401 ZPED=VLT/CUX 6402 IROW2=ITAG(IROW1) 6403 PWR=.5*DREAL(VLT*DCONJG(CUX)) 6404 PNLS=PNLS-PWR 640546 IF (NPRINT.EQ.0) WRITE(3,62) IROW2,IROW1,VLT,CUX,ZPED,YMIT,PWR 6406 IF (NTSC.EQ.0) GO TO 49 6407 DO 47 I=1,NTSC 6408 IROW1=NTSCA(I) 6409 VLT=VSRC(I) 6410 CUX=EINC(IROW1)*WLAM 6411 YMIT=CUX/VLT 6412 ZPED=VLT/CUX 6413 IROW2=ITAG(IROW1) 6414 PWR=.5*DREAL(VLT*DCONJG(CUX)) 6415 PNLS=PNLS-PWR 641647 IF (NPRINT.EQ.0) WRITE(3,62) IROW2,IROW1,VLT,CUX,ZPED,YMIT,PWR 6417 GO TO 49 6418C 6419C SOLVE FOR CURRENTS WHEN NO NETWORKS ARE PRESENT 6420C 642148 CALL SOLGF (CM,CMB,CMC,CMD,EINC,IP,NP,N1,N,MP,M1,M,NEQ,NEQ2,NEQZ2) 6422 CALL CABC (EINC) 6423 NTSC=0 642449 IF (NSANT+NVQD.EQ.0) RETURN 6425 WRITE(3,63) 6426 WRITE(3,60) 6427 IF (NSANT.EQ.0) GO TO 56 6428 DO 55 I=1,NSANT 6429 ISC1=ISANT(I) 6430 VLT=VSANT(I) 6431 IF (NTSC.EQ.0) GO TO 51 6432 DO 50 J=1,NTSC 6433 IF (NTSCA(J).EQ.ISC1) GO TO 52 643450 CONTINUE 643551 CUX=EINC(ISC1)*WLAM 6436 IROW1=0 6437 GO TO 54 643852 IROW1=NDIMNP-J 6439 CUX=RHNX(IROW1) 6440 DO 53 J=1,NTEQ 644153 CUX=CUX-CMN(J,IROW1)*RHNT(J) 6442 CUX=(EINC(ISC1)+CUX)*WLAM 644354 YMIT=CUX/VLT 6444 ZPED=VLT/CUX 6445 PWR=.5*DREAL(VLT*DCONJG(CUX)) 6446 PIN=PIN+PWR 6447 IF (IROW1.NE.0) PNLS=PNLS+PWR 6448 IROW2=ITAG(ISC1) 644955 WRITE(3,62) IROW2,ISC1,VLT,CUX,ZPED,YMIT,PWR 645056 IF (NVQD.EQ.0) RETURN 6451 DO 57 I=1,NVQD 6452 ISC1=IVQD(I) 6453 VLT=VQD(I) 6454 CUX=DCMPLX(AIR(ISC1),AII(ISC1)) 6455 YMIT=DCMPLX(BIR(ISC1),BII(ISC1)) 6456 ZPED=DCMPLX(CIR(ISC1),CII(ISC1)) 6457 PWR=SI(ISC1)*TP*.5 6458 CUX=(CUX-YMIT*SIN(PWR)+ZPED*COS(PWR))*WLAM 6459 YMIT=CUX/VLT 6460 ZPED=VLT/CUX 6461 PWR=.5*DREAL(VLT*DCONJG(CUX)) 6462 PIN=PIN+PWR 6463 IROW2=ITAG(ISC1) 646457 WRITE(3,64) IROW2,ISC1,VLT,CUX,ZPED,YMIT,PWR 6465 RETURN 6466C 646758 FORMAT (///,3X,47HMAXIMUM RELATIVE ASYMMETRY OF THE DRIVING POINT, 6468 121H ADMITTANCE MATRIX IS,1P,E10.3,13H FOR SEGMENTS,I5,4H AND,I5,/, 6469 23X,25HRMS RELATIVE ASYMMETRY IS,E10.3) 647059 FORMAT (1X,44HERROR - - NETWORK ARRAY DIMENSIONS TOO SMALL) 647160 FORMAT (/,3X,3HTAG,3X,4HSEG.,4X,15HVOLTAGE (VOLTS),9X,14HCURRENT ( 6472 1AMPS),9X,16HIMPEDANCE (OHMS),8X,17HADMITTANCE (MHOS),6X,5HPOWER,/, 6473 23X,3HNO.,3X,3HNO.,4X,4HREAL,8X,5HIMAG.,3(7X,4HREAL,8X,5HIMAG.),5X, 6474 37H(WATTS)) 647561 FORMAT (///,27X,66H- - - STRUCTURE EXCITATION DATA AT NETWORK CONN 6476 1ECTION POINTS - - -) 647762 FORMAT (2(1X,I5),1P,9E12.5) 647863 FORMAT (///,42X,36H- - - ANTENNA INPUT PARAMETERS - - -) 647964 FORMAT (1X,I5,2H *,I4,1P,9E12.5) 6480 END 6481 SUBROUTINE NFPAT 6482C *** 6483C DOUBLE PRECISION 6/4/85 6484C 6485 PARAMETER (MAXSEG=1500, MAXMAT=1500) 6486 IMPLICIT REAL*8(A-H,O-Z) 6487C *** 6488C COMPUTE NEAR E OR H FIELDS OVER A RANGE OF POINTS 6489 COMPLEX*16 EX,EY,EZ 6490 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 6491 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 6492 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 6493 COMMON/FPAT/THETS,PHIS,DTH,DPH,RFLD,GNOR,CLT,CHT,EPSR2,SIG2, 6494 &XPR6,PINR,PNLR,PLOSS,XNR,YNR,ZNR,DXNR,DYNR,DZNR,NTH,NPH,IPD,IAVP, 6495 &INOR,IAX,IXTYP,NEAR,NFEH,NRX,NRY,NRZ 6496C*** 6497 COMMON /PLOT/ IPLP1,IPLP2,IPLP3,IPLP4 6498C*** 6499 DATA TA/1.745329252D-02/ 6500 IF (NFEH.EQ.1) GO TO 1 6501 WRITE(3,10) 6502 GO TO 2 65031 WRITE(3,12) 65042 ZNRT=ZNR-DZNR 6505 DO 9 I=1,NRZ 6506 ZNRT=ZNRT+DZNR 6507 IF (NEAR.EQ.0) GO TO 3 6508 CTH=COS(TA*ZNRT) 6509 STH=SIN(TA*ZNRT) 65103 YNRT=YNR-DYNR 6511 DO 9 J=1,NRY 6512 YNRT=YNRT+DYNR 6513 IF (NEAR.EQ.0) GO TO 4 6514 CPH=COS(TA*YNRT) 6515 SPH=SIN(TA*YNRT) 65164 XNRT=XNR-DXNR 6517 DO 9 KK=1,NRX 6518 XNRT=XNRT+DXNR 6519 IF (NEAR.EQ.0) GO TO 5 6520 XOB=XNRT*STH*CPH 6521 YOB=XNRT*STH*SPH 6522 ZOB=XNRT*CTH 6523 GO TO 6 65245 XOB=XNRT 6525 YOB=YNRT 6526 ZOB=ZNRT 65276 TMP1=XOB/WLAM 6528 TMP2=YOB/WLAM 6529 TMP3=ZOB/WLAM 6530 IF (NFEH.EQ.1) GO TO 7 6531 CALL NEFLD (TMP1,TMP2,TMP3,EX,EY,EZ) 6532 GO TO 8 65337 CALL NHFLD (TMP1,TMP2,TMP3,EX,EY,EZ) 65348 TMP1=ABS(EX) 6535 TMP2=CANG(EX) 6536 TMP3=ABS(EY) 6537 TMP4=CANG(EY) 6538 TMP5=ABS(EZ) 6539 TMP6=CANG(EZ) 6540 WRITE(3,11) XOB,YOB,ZOB,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6 6541C*** 6542 IF(IPLP1 .NE. 2) GO TO 9 6543 GO TO (14,15,16),IPLP4 654414 XXX=XOB 6545 GO TO 17 654615 XXX=YOB 6547 GO TO 17 654816 XXX=ZOB 654917 CONTINUE 6550 IF(IPLP2 .NE. 2) GO TO 13 6551 IF(IPLP3 .EQ. 1) WRITE(8,*) XXX,TMP1,TMP2 6552 IF(IPLP3 .EQ. 2) WRITE(8,*) XXX,TMP3,TMP4 6553 IF(IPLP3 .EQ. 3) WRITE(8,*) XXX,TMP5,TMP6 6554 IF(IPLP3 .EQ. 4) WRITE(8,*) XXX,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6 6555 GO TO 9 655613 IF(IPLP2 .NE. 1) GO TO 9 6557 IF(IPLP3 .EQ. 1) WRITE(8,*) XXX,EX 6558 IF(IPLP3 .EQ. 2) WRITE(8,*) XXX,EY 6559 IF(IPLP3 .EQ. 3) WRITE(8,*) XXX,EZ 6560 IF(IPLP3 .EQ. 4) WRITE(8,*) XXX,EX,EY,EZ 6561C*** 65629 CONTINUE 6563 RETURN 6564C 656510 FORMAT (///,35X,32H- - - NEAR ELECTRIC FIELDS - - -,//,12X,14H- L 6566 1OCATION -,21X,8H- EX -,15X,8H- EY -,15X,8H- EZ -,/,8X,1HX,1 6567 20X,1HY,10X,1HZ,10X,9HMAGNITUDE,3X,5HPHASE,6X,9HMAGNITUDE,3X,5HPHAS 6568 3E,6X,9HMAGNITUDE,3X,5HPHASE,/,6X,6HMETERS,5X,6HMETERS,5X,6HMETERS, 6569 48X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3 6570 5X,7HDEGREES) 657111 FORMAT (2X,3(2X,F9.4),1X,3(3X,1P,E11.4,2X,0P,F7.2)) 657212 FORMAT (///,35X,32H- - - NEAR MAGNETIC FIELDS - - -,//,12X,14H- L 6573 1OCATION -,21X,8H- HX -,15X,8H- HY -,15X,8H- HZ -,/,8X,1HX,1 6574 20X,1HY,10X,1HZ,10X,9HMAGNITUDE,3X,5HPHASE,6X,9HMAGNITUDE,3X,5HPHAS 6575 3E,6X,9HMAGNITUDE,3X,5HPHASE,/,6X,6HMETERS,5X,6HMETERS,5X,6HMETERS, 6576 49X,6HAMPS/M,3X,7HDEGREES,7X,6HAMPS/M,3X,7HDEGREES,7X,6HAMPS/M,3X,7 6577 5HDEGREES) 6578 END 6579 SUBROUTINE NHFLD (XOB,YOB,ZOB,HX,HY,HZ) 6580C 6581C NHFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER 6582C THE STRUCTURE CURRENTS HAVE BEEN COMPUTED. 6583C 6584 PARAMETER (MAXSEG=1500, MAXMAT=1500) 6585 IMPLICIT REAL*8(A-H,O-Z) 6586 COMPLEX*16 HX,HY,HZ,CUR,ACX,BCX,CCX,EXK,EYK,EZK,EXS,EYS,EZS,EXC, 6587 &EYC,EZC 6588C*************************************** 6589 COMPLEX*16 ZRATI,ZRATI2,FRATI,T1,CON 6590 COMPLEX*16 EXPX,EXMX,EXPY,EXMY,EXPZ,EXMZ 6591 COMPLEX*16 EYPX,EYMX,EYPY,EYMY,EYPZ,EYMZ 6592 COMPLEX*16 EZPX,EZMX,EZPY,EZMY,EZPZ,EZMZ 6593 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 6594 &KSYMP,IFAR,IPERF 6595C*************************************** 6596 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 6597 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 6598 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 6599 COMMON /ANGL/ SALP(MAXSEG) 6600 COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG), 6601 &CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG) 6602 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 6603 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 6604 DIMENSION CAB(1), SAB(1) 6605 DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), XS(1), Y 6606 1S(1), ZS(1) 6607 EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON 6608 12), (T2Z,ITAG), (XS,X), (YS,Y), (ZS,Z) 6609 EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y 6610 1J,IND1), (T2ZJ,IND2) 6611 EQUIVALENCE (CAB,ALP), (SAB,BET) 6612C*************************************** 6613 IF (IPERF.EQ.2) GO TO 6 6614C*************************************** 6615 HX=(0.,0.) 6616 HY=(0.,0.) 6617 HZ=(0.,0.) 6618 AX=0. 6619 IF (N.EQ.0) GO TO 4 6620 DO 1 I=1,N 6621 XJ=XOB-X(I) 6622 YJ=YOB-Y(I) 6623 ZJ=ZOB-Z(I) 6624 ZP=CAB(I)*XJ+SAB(I)*YJ+SALP(I)*ZJ 6625 IF (ABS(ZP).GT.0.5001*SI(I)) GO TO 1 6626 ZP=XJ*XJ+YJ*YJ+ZJ*ZJ-ZP*ZP 6627 XJ=BI(I) 6628 IF (ZP.GT.0.9*XJ*XJ) GO TO 1 6629 AX=XJ 6630 GO TO 2 66311 CONTINUE 66322 DO 3 I=1,N 6633 S=SI(I) 6634 B=BI(I) 6635 XJ=X(I) 6636 YJ=Y(I) 6637 ZJ=Z(I) 6638 CABJ=CAB(I) 6639 SABJ=SAB(I) 6640 SALPJ=SALP(I) 6641 CALL HSFLD (XOB,YOB,ZOB,AX) 6642 ACX=DCMPLX(AIR(I),AII(I)) 6643 BCX=DCMPLX(BIR(I),BII(I)) 6644 CCX=DCMPLX(CIR(I),CII(I)) 6645 HX=HX+EXK*ACX+EXS*BCX+EXC*CCX 6646 HY=HY+EYK*ACX+EYS*BCX+EYC*CCX 66473 HZ=HZ+EZK*ACX+EZS*BCX+EZC*CCX 6648 IF (M.EQ.0) RETURN 66494 JC=N 6650 JL=LD+1 6651 DO 5 I=1,M 6652 JL=JL-1 6653 S=BI(JL) 6654 XJ=X(JL) 6655 YJ=Y(JL) 6656 ZJ=Z(JL) 6657 T1XJ=T1X(JL) 6658 T1YJ=T1Y(JL) 6659 T1ZJ=T1Z(JL) 6660 T2XJ=T2X(JL) 6661 T2YJ=T2Y(JL) 6662 T2ZJ=T2Z(JL) 6663 CALL HINTG (XOB,YOB,ZOB) 6664 JC=JC+3 6665 ACX=T1XJ*CUR(JC-2)+T1YJ*CUR(JC-1)+T1ZJ*CUR(JC) 6666 BCX=T2XJ*CUR(JC-2)+T2YJ*CUR(JC-1)+T2ZJ*CUR(JC) 6667 HX=HX+ACX*EXK+BCX*EXS 6668 HY=HY+ACX*EYK+BCX*EYS 66695 HZ=HZ+ACX*EZK+BCX*EZS 6670 RETURN 6671C 6672C GET H BY FINITE DIFFERENCE OF E FOR SOMMERFELD GROUND 6673C CON=j/(2*pi*eta) 6674C DELT is the increment for getting central differences 6675C 66766 DELT=1.E-3 6677 CON=(0.,4.2246E-4) 6678 CALL NEFLD (XOB+DELT,YOB,ZOB,EXPX,EYPX,EZPX) 6679 CALL NEFLD (XOB-DELT,YOB,ZOB,EXMX,EYMX,EZMX) 6680 CALL NEFLD (XOB,YOB+DELT,ZOB,EXPY,EYPY,EZPY) 6681 CALL NEFLD (XOB,YOB-DELT,ZOB,EXMY,EYMY,EZMY) 6682 CALL NEFLD (XOB,YOB,ZOB+DELT,EXPZ,EYPZ,EZPZ) 6683 CALL NEFLD (XOB,YOB,ZOB-DELT,EXMZ,EYMZ,EZMZ) 6684 HX=CON*(EZPY-EZMY-EYPZ+EYMZ)/(2.*DELT) 6685 HY=CON*(EXPZ-EXMZ-EZPX+EZMX)/(2.*DELT) 6686 HZ=CON*(EYPX-EYMX-EXPY+EXMY)/(2.*DELT) 6687 RETURN 6688 END 6689 SUBROUTINE PATCH (NX,NY,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4) 6690C *** 6691C DOUBLE PRECISION 6/4/85 6692C 6693 PARAMETER (MAXSEG=1500, MAXMAT=1500) 6694 IMPLICIT REAL*8(A-H,O-Z) 6695C *** 6696C PATCH GENERATES AND MODIFIES PATCH GEOMETRY DATA 6697 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 6698 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 6699 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 6700 COMMON /ANGL/ SALP(MAXSEG) 6701 DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) 6702 EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON 6703 12), (T2Z,ITAG) 6704C NEW PATCHES. FOR NX=0, NY=1,2,3,4 PATCH IS (RESPECTIVELY) 6705C ARBITRARY, RECTAGULAR, TRIANGULAR, OR QUADRILATERAL. 6706C FOR NX AND NY .GT. 0 A RECTANGULAR SURFACE IS PRODUCED WITH 6707C NX BY NY RECTANGULAR PATCHES. 6708 M=M+1 6709 MI=LD+1-M 6710 NTP=NY 6711 IF (NX.GT.0) NTP=2 6712 IF (NTP.GT.1) GO TO 2 6713 X(MI)=X1 6714 Y(MI)=Y1 6715 Z(MI)=Z1 6716 BI(MI)=Z2 6717 ZNV=COS(X2) 6718 XNV=ZNV*COS(Y2) 6719 YNV=ZNV*SIN(Y2) 6720 ZNV=SIN(X2) 6721 XA=SQRT(XNV*XNV+YNV*YNV) 6722 IF (XA.LT.1.D-6) GO TO 1 6723 T1X(MI)=-YNV/XA 6724 T1Y(MI)=XNV/XA 6725 T1Z(MI)=0. 6726 GO TO 6 67271 T1X(MI)=1. 6728 T1Y(MI)=0. 6729 T1Z(MI)=0. 6730 GO TO 6 67312 S1X=X2-X1 6732 S1Y=Y2-Y1 6733 S1Z=Z2-Z1 6734 S2X=X3-X2 6735 S2Y=Y3-Y2 6736 S2Z=Z3-Z2 6737 IF (NX.EQ.0) GO TO 3 6738 S1X=S1X/NX 6739 S1Y=S1Y/NX 6740 S1Z=S1Z/NX 6741 S2X=S2X/NY 6742 S2Y=S2Y/NY 6743 S2Z=S2Z/NY 67443 XNV=S1Y*S2Z-S1Z*S2Y 6745 YNV=S1Z*S2X-S1X*S2Z 6746 ZNV=S1X*S2Y-S1Y*S2X 6747 XA=SQRT(XNV*XNV+YNV*YNV+ZNV*ZNV) 6748 XNV=XNV/XA 6749 YNV=YNV/XA 6750 ZNV=ZNV/XA 6751 XST=SQRT(S1X*S1X+S1Y*S1Y+S1Z*S1Z) 6752 T1X(MI)=S1X/XST 6753 T1Y(MI)=S1Y/XST 6754 T1Z(MI)=S1Z/XST 6755 IF (NTP.GT.2) GO TO 4 6756 X(MI)=X1+.5*(S1X+S2X) 6757 Y(MI)=Y1+.5*(S1Y+S2Y) 6758 Z(MI)=Z1+.5*(S1Z+S2Z) 6759 BI(MI)=XA 6760 GO TO 6 67614 IF (NTP.EQ.4) GO TO 5 6762 X(MI)=(X1+X2+X3)/3. 6763 Y(MI)=(Y1+Y2+Y3)/3. 6764 Z(MI)=(Z1+Z2+Z3)/3. 6765 BI(MI)=.5*XA 6766 GO TO 6 67675 S1X=X3-X1 6768 S1Y=Y3-Y1 6769 S1Z=Z3-Z1 6770 S2X=X4-X1 6771 S2Y=Y4-Y1 6772 S2Z=Z4-Z1 6773 XN2=S1Y*S2Z-S1Z*S2Y 6774 YN2=S1Z*S2X-S1X*S2Z 6775 ZN2=S1X*S2Y-S1Y*S2X 6776 XST=SQRT(XN2*XN2+YN2*YN2+ZN2*ZN2) 6777 SALPN=1./(3.*(XA+XST)) 6778 X(MI)=(XA*(X1+X2+X3)+XST*(X1+X3+X4))*SALPN 6779 Y(MI)=(XA*(Y1+Y2+Y3)+XST*(Y1+Y3+Y4))*SALPN 6780 Z(MI)=(XA*(Z1+Z2+Z3)+XST*(Z1+Z3+Z4))*SALPN 6781 BI(MI)=.5*(XA+XST) 6782 S1X=(XNV*XN2+YNV*YN2+ZNV*ZN2)/XST 6783 IF (S1X.GT.0.9998) GO TO 6 6784 WRITE(3,14) 6785 STOP 67866 T2X(MI)=YNV*T1Z(MI)-ZNV*T1Y(MI) 6787 T2Y(MI)=ZNV*T1X(MI)-XNV*T1Z(MI) 6788 T2Z(MI)=XNV*T1Y(MI)-YNV*T1X(MI) 6789 SALP(MI)=1. 6790 IF (NX.EQ.0) GO TO 8 6791 M=M+NX*NY-1 6792 XN2=X(MI)-S1X-S2X 6793 YN2=Y(MI)-S1Y-S2Y 6794 ZN2=Z(MI)-S1Z-S2Z 6795 XS=T1X(MI) 6796 YS=T1Y(MI) 6797 ZS=T1Z(MI) 6798 XT=T2X(MI) 6799 YT=T2Y(MI) 6800 ZT=T2Z(MI) 6801 MI=MI+1 6802 DO 7 IY=1,NY 6803 XN2=XN2+S2X 6804 YN2=YN2+S2Y 6805 ZN2=ZN2+S2Z 6806 DO 7 IX=1,NX 6807 XST=IX 6808 MI=MI-1 6809 X(MI)=XN2+XST*S1X 6810 Y(MI)=YN2+XST*S1Y 6811 Z(MI)=ZN2+XST*S1Z 6812 BI(MI)=XA 6813 SALP(MI)=1. 6814 T1X(MI)=XS 6815 T1Y(MI)=YS 6816 T1Z(MI)=ZS 6817 T2X(MI)=XT 6818 T2Y(MI)=YT 68197 T2Z(MI)=ZT 68208 IPSYM=0 6821 NP=N 6822 MP=M 6823 RETURN 6824C DIVIDE PATCH FOR WIRE CONNECTION 6825 ENTRY SUBPH (NX,NY,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4) 6826 IF (NY.GT.0) GO TO 10 6827 IF (NX.EQ.M) GO TO 10 6828 NXP=NX+1 6829 IX=LD-M 6830 DO 9 IY=NXP,M 6831 IX=IX+1 6832 NYP=IX-3 6833 X(NYP)=X(IX) 6834 Y(NYP)=Y(IX) 6835 Z(NYP)=Z(IX) 6836 BI(NYP)=BI(IX) 6837 SALP(NYP)=SALP(IX) 6838 T1X(NYP)=T1X(IX) 6839 T1Y(NYP)=T1Y(IX) 6840 T1Z(NYP)=T1Z(IX) 6841 T2X(NYP)=T2X(IX) 6842 T2Y(NYP)=T2Y(IX) 68439 T2Z(NYP)=T2Z(IX) 684410 MI=LD+1-NX 6845 XS=X(MI) 6846 YS=Y(MI) 6847 ZS=Z(MI) 6848 XA=BI(MI)*.25 6849 XST=SQRT(XA)*.5 6850 S1X=T1X(MI) 6851 S1Y=T1Y(MI) 6852 S1Z=T1Z(MI) 6853 S2X=T2X(MI) 6854 S2Y=T2Y(MI) 6855 S2Z=T2Z(MI) 6856 SALN=SALP(MI) 6857 XT=XST 6858 YT=XST 6859 IF (NY.GT.0) GO TO 11 6860 MIA=MI 6861 GO TO 12 686211 M=M+1 6863 MP=MP+1 6864 MIA=LD+1-M 686512 DO 13 IX=1,4 6866 X(MIA)=XS+XT*S1X+YT*S2X 6867 Y(MIA)=YS+XT*S1Y+YT*S2Y 6868 Z(MIA)=ZS+XT*S1Z+YT*S2Z 6869 BI(MIA)=XA 6870 T1X(MIA)=S1X 6871 T1Y(MIA)=S1Y 6872 T1Z(MIA)=S1Z 6873 T2X(MIA)=S2X 6874 T2Y(MIA)=S2Y 6875 T2Z(MIA)=S2Z 6876 SALP(MIA)=SALN 6877 IF (IX.EQ.2) YT=-YT 6878 IF (IX.EQ.1.OR.IX.EQ.3) XT=-XT 6879 MIA=MIA-1 688013 CONTINUE 6881 M=M+3 6882 IF (NX.LE.MP) MP=MP+3 6883 IF (NY.GT.0) Z(MI)=10000. 6884 RETURN 6885C 688614 FORMAT (62H ERROR -- CORNERS OF QUADRILATERAL PATCH DO NOT LIE IN 6887 1A PLANE) 6888 END 6889 SUBROUTINE PCINT (XI,YI,ZI,CABI,SABI,SALPI,E) 6890C *** 6891C DOUBLE PRECISION 6/4/85 6892C 6893 IMPLICIT REAL*8(A-H,O-Z) 6894C *** 6895C INTEGRATE OVER PATCHES AT WIRE CONNECTION POINT 6896 COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,E,E1,E2,E3,E4,E5 6897 1,E6,E7,E8,E9 6898 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 6899 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 6900 DIMENSION E(9) 6901 EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y 6902 1J,IND1), (T2ZJ,IND2) 6903 DATA TPI/6.283185308D+0/,NINT/10/ 6904 D=SQRT(S)*.5 6905 DS=4.*D/DFLOAT(NINT) 6906 DA=DS*DS 6907 GCON=1./S 6908 FCON=1./(2.*TPI*D) 6909 XXJ=XJ 6910 XYJ=YJ 6911 XZJ=ZJ 6912 XS=S 6913 S=DA 6914 S1=D+DS*.5 6915 XSS=XJ+S1*(T1XJ+T2XJ) 6916 YSS=YJ+S1*(T1YJ+T2YJ) 6917 ZSS=ZJ+S1*(T1ZJ+T2ZJ) 6918 S1=S1+D 6919 S2X=S1 6920 E1=(0.,0.) 6921 E2=(0.,0.) 6922 E3=(0.,0.) 6923 E4=(0.,0.) 6924 E5=(0.,0.) 6925 E6=(0.,0.) 6926 E7=(0.,0.) 6927 E8=(0.,0.) 6928 E9=(0.,0.) 6929 DO 1 I1=1,NINT 6930 S1=S1-DS 6931 S2=S2X 6932 XSS=XSS-DS*T1XJ 6933 YSS=YSS-DS*T1YJ 6934 ZSS=ZSS-DS*T1ZJ 6935 XJ=XSS 6936 YJ=YSS 6937 ZJ=ZSS 6938 DO 1 I2=1,NINT 6939 S2=S2-DS 6940 XJ=XJ-DS*T2XJ 6941 YJ=YJ-DS*T2YJ 6942 ZJ=ZJ-DS*T2ZJ 6943 CALL UNERE (XI,YI,ZI) 6944 EXK=EXK*CABI+EYK*SABI+EZK*SALPI 6945 EXS=EXS*CABI+EYS*SABI+EZS*SALPI 6946 G1=(D+S1)*(D+S2)*GCON 6947 G2=(D-S1)*(D+S2)*GCON 6948 G3=(D-S1)*(D-S2)*GCON 6949 G4=(D+S1)*(D-S2)*GCON 6950 F2=(S1*S1+S2*S2)*TPI 6951 F1=S1/F2-(G1-G2-G3+G4)*FCON 6952 F2=S2/F2-(G1+G2-G3-G4)*FCON 6953 E1=E1+EXK*G1 6954 E2=E2+EXK*G2 6955 E3=E3+EXK*G3 6956 E4=E4+EXK*G4 6957 E5=E5+EXS*G1 6958 E6=E6+EXS*G2 6959 E7=E7+EXS*G3 6960 E8=E8+EXS*G4 69611 E9=E9+EXK*F1+EXS*F2 6962 E(1)=E1 6963 E(2)=E2 6964 E(3)=E3 6965 E(4)=E4 6966 E(5)=E5 6967 E(6)=E6 6968 E(7)=E7 6969 E(8)=E8 6970 E(9)=E9 6971 XJ=XXJ 6972 YJ=XYJ 6973 ZJ=XZJ 6974 S=XS 6975 RETURN 6976 END 6977 SUBROUTINE PRNT(IN1,IN2,IN3,FL1,FL2,FL3,FL4,FL5,FL6,CTYPE) 6978C 6979C Purpose: 6980C PRNT prints the input data for impedance loading, inserting blanks 6981C for numbers that are zero. 6982C 6983C INPUT: 6984C IN1-3 = INTEGER VALUES TO BE PRINTED 6985C FL1-6 = REAL VALUES TO BE PRINTED 6986C CTYPE = CHARACTER STRING TO BE PRINTED 6987C 6988 IMPLICIT REAL*8(A-H,O-Z) 6989 CHARACTER CTYPE*(*), CINT(3)*5, CFLT(6)*13 6990C 6991 DO 1 I=1,3 69921 CINT(I)=' ' 6993 IF(IN1.EQ.0.AND.IN2.EQ.0.AND.IN3.EQ.0)THEN 6994 CINT(1)=' ALL' 6995 ELSE 6996 IF(IN1.NE.0)WRITE(CINT(1),90)IN1 6997 IF(IN2.NE.0)WRITE(CINT(2),90)IN2 6998 IF(IN3.NE.0)WRITE(CINT(3),90)IN3 6999 END IF 7000 DO 2 I=1,6 70012 CFLT(I)=' ' 7002 IF(ABS(FL1).GT.1.E-30)WRITE(CFLT(1),91)FL1 7003 IF(ABS(FL2).GT.1.E-30)WRITE(CFLT(2),91)FL2 7004 IF(ABS(FL3).GT.1.E-30)WRITE(CFLT(3),91)FL3 7005 IF(ABS(FL4).GT.1.E-30)WRITE(CFLT(4),91)FL4 7006 IF(ABS(FL5).GT.1.E-30)WRITE(CFLT(5),91)FL5 7007 IF(ABS(FL6).GT.1.E-30)WRITE(CFLT(6),91)FL6 7008 WRITE(3,92)(CINT(I),I=1,3),(CFLT(I),I=1,6),CTYPE 7009 RETURN 7010C 701190 FORMAT(I5) 701291 FORMAT(1P,E13.4) 701392 FORMAT(/,3X,3A,3X,6A,3X,A) 7014 END 7015 SUBROUTINE QDSRC (IS,V,E) 7016C *** 7017C DOUBLE PRECISION 6/4/85 7018C 7019 PARAMETER (MAXSEG=1500, MAXMAT=1500) 7020 IMPLICIT REAL*8(A-H,O-Z) 7021C *** 7022C FILL INCIDENT FIELD ARRAY FOR CHARGE DISCONTINUITY VOLTAGE SOURCE 7023 COMPLEX*16 VQDS,CURD,CCJ,V,EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC 7024 1,ETK,ETS,ETC,VSANT,VQD,E,ZARRAY 7025 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 7026 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 7027 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 7028 COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),IQDS( 7029 130),NVQD,NSANT,NQDS 7030 COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP 7031 1CON(10),NPCON 7032 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 7033 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 7034 COMMON /ANGL/ SALP(MAXSEG) 7035 COMMON /ZLOAD/ ZARRAY(MAXSEG),NLOAD,NLODF 7036 DIMENSION CCJX(2), E(1), CAB(1), SAB(1) 7037 DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) 7038 EQUIVALENCE (CCJ,CCJX), (CAB,ALP), (SAB,BET) 7039 EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON 7040 12), (T2Z,ITAG) 7041 DATA TP/6.283185308D+0/,CCJX/0.,-.01666666667D+0/ 7042 I=ICON1(IS) 7043 ICON1(IS)=0 7044 CALL TBF (IS,0) 7045 ICON1(IS)=I 7046 S=SI(IS)*.5 7047 CURD=CCJ*V/((LOG(2.*S/BI(IS))-1.)*(BX(JSNO)*COS(TP*S)+CX(JSNO)*SI 7048 1N(TP*S))*WLAM) 7049 NQDS=NQDS+1 7050 VQDS(NQDS)=V 7051 IQDS(NQDS)=IS 7052 DO 20 JX=1,JSNO 7053 J=JCO(JX) 7054 S=SI(J) 7055 B=BI(J) 7056 XJ=X(J) 7057 YJ=Y(J) 7058 ZJ=Z(J) 7059 CABJ=CAB(J) 7060 SABJ=SAB(J) 7061 SALPJ=SALP(J) 7062 IF (IEXK.EQ.0) GO TO 16 7063 IPR=ICON1(J) 7064 IF (IPR) 1,6,2 70651 IPR=-IPR 7066 IF (-ICON1(IPR).NE.J) GO TO 7 7067 GO TO 4 70682 IF (IPR.NE.J) GO TO 3 7069 IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 7 7070 GO TO 5 70713 IF (ICON2(IPR).NE.J) GO TO 7 70724 XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR)) 7073 IF (XI.LT.0.999999D+0) GO TO 7 7074 IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 7 70755 IND1=0 7076 GO TO 8 70776 IND1=1 7078 GO TO 8 70797 IND1=2 70808 IPR=ICON2(J) 7081 IF (IPR) 9,14,10 70829 IPR=-IPR 7083 IF (-ICON2(IPR).NE.J) GO TO 15 7084 GO TO 12 708510 IF (IPR.NE.J) GO TO 11 7086 IF (CABJ*CABJ+SABJ*SABJ.GT.1.D-8) GO TO 15 7087 GO TO 13 708811 IF (ICON1(IPR).NE.J) GO TO 15 708912 XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR)) 7090 IF (XI.LT.0.999999D+0) GO TO 15 7091 IF (ABS(BI(IPR)/B-1.).GT.1.D-6) GO TO 15 709213 IND2=0 7093 GO TO 16 709414 IND2=1 7095 GO TO 16 709615 IND2=2 709716 CONTINUE 7098 DO 17 I=1,N 7099 IJ=I-J 7100 XI=X(I) 7101 YI=Y(I) 7102 ZI=Z(I) 7103 AI=BI(I) 7104 CALL EFLD (XI,YI,ZI,AI,IJ) 7105 CABI=CAB(I) 7106 SABI=SAB(I) 7107 SALPI=SALP(I) 7108 ETK=EXK*CABI+EYK*SABI+EZK*SALPI 7109 ETS=EXS*CABI+EYS*SABI+EZS*SALPI 7110 ETC=EXC*CABI+EYC*SABI+EZC*SALPI 711117 E(I)=E(I)-(ETK*AX(JX)+ETS*BX(JX)+ETC*CX(JX))*CURD 7112 IF (M.EQ.0) GO TO 19 7113 IJ=LD+1 7114 I1=N 7115 DO 18 I=1,M 7116 IJ=IJ-1 7117 XI=X(IJ) 7118 YI=Y(IJ) 7119 ZI=Z(IJ) 7120 CALL HSFLD (XI,YI,ZI,0.D0) 7121 I1=I1+1 7122 TX=T2X(IJ) 7123 TY=T2Y(IJ) 7124 TZ=T2Z(IJ) 7125 ETK=EXK*TX+EYK*TY+EZK*TZ 7126 ETS=EXS*TX+EYS*TY+EZS*TZ 7127 ETC=EXC*TX+EYC*TY+EZC*TZ 7128 E(I1)=E(I1)+(ETK*AX(JX)+ETS*BX(JX)+ETC*CX(JX))*CURD*SALP(IJ) 7129 I1=I1+1 7130 TX=T1X(IJ) 7131 TY=T1Y(IJ) 7132 TZ=T1Z(IJ) 7133 ETK=EXK*TX+EYK*TY+EZK*TZ 7134 ETS=EXS*TX+EYS*TY+EZS*TZ 7135 ETC=EXC*TX+EYC*TY+EZC*TZ 713618 E(I1)=E(I1)+(ETK*AX(JX)+ETS*BX(JX)+ETC*CX(JX))*CURD*SALP(IJ) 713719 IF (NLOAD.GT.0.OR.NLODF.GT.0) E(J)=E(J)+ZARRAY(J)*CURD*(AX(JX)+CX( 7138 1JX)) 713920 CONTINUE 7140 RETURN 7141 END 7142 SUBROUTINE RDPAT 7143C *** 7144C DOUBLE PRECISION 6/4/85 7145C 7146 PARAMETER (MAXSEG=1500, MAXMAT=1500) 7147 PARAMETER(NORMAX=4*MAXSEG) 7148 IMPLICIT REAL*8(A-H,O-Z) 7149C *** 7150C COMPUTE RADIATION PATTERN, GAIN, NORMALIZED GAIN 7151 REAL*8 IGNTP,IGAX,IGTP,HCIR,HBLK,HPOL,HCLIF,ISENS 7152C INTEGER HPOL,HBLK,HCIR,HCLIF 7153 COMPLEX*16 ETH,EPH,ERD,ZRATI,ZRATI2,T1,FRATI 7154 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 7155 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 7156 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 7157 COMMON/SAVE/EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(2*MAXSEG),KCOM 7158 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 7159 &KSYMP,IFAR,IPERF 7160 COMMON/FPAT/THETS,PHIS,DTH,DPH,RFLD,GNOR,CLT,CHT,EPSR2,SIG2, 7161 &XPR6,PINR,PNLR,PLOSS,XNR,YNR,ZNR,DXNR,DYNR,DZNR,NTH,NPH,IPD,IAVP, 7162 &INOR,IAX,IXTYP,NEAR,NFEH,NRX,NRY,NRZ 7163 COMMON /SCRATM/ GAIN(NORMAX) 7164C*** 7165 COMMON /PLOT/ IPLP1,IPLP2,IPLP3,IPLP4 7166C*** 7167 DIMENSION IGTP(4), IGAX(4), IGNTP(10), HPOL(3) 7168 DATA HPOL/6HLINEAR,5HRIGHT,4HLEFT/,HBLK,HCIR/1H ,6HCIRCLE/ 7169 DATA IGTP/6H - ,6HPOWER ,6H- DIRE,6HCTIVE / 7170 DATA IGAX/6H MAJOR,6H MINOR,6H VERT.,6H HOR. / 7171 DATA IGNTP/6H MAJOR,6H AXIS ,6H MINOR,6H AXIS ,6H VER,6HTICAL ,6 7172 1H HORIZ,6HONTAL ,6H ,6HTOTAL / 7173 DATA PI,TA,TD/3.141592654D+0,1.745329252D-02,57.29577951D+0/ 7174 IF (IFAR.LT.2) GO TO 2 7175 WRITE(3,35) 7176 IF (IFAR.LE.3) GO TO 1 7177 WRITE(3,36) NRADL,SCRWLT,SCRWRT 7178 IF (IFAR.EQ.4) GO TO 2 71791 IF (IFAR.EQ.2.OR.IFAR.EQ.5) HCLIF=HPOL(1) 7180 IF (IFAR.EQ.3.OR.IFAR.EQ.6) HCLIF=HCIR 7181 CL=CLT/WLAM 7182 CH=CHT/WLAM 7183 ZRATI2=SQRT(1./DCMPLX(EPSR2,-SIG2*WLAM*59.96)) 7184 WRITE(3,37) HCLIF,CLT,CHT,EPSR2,SIG2 71852 IF (IFAR.NE.1) GO TO 3 7186 WRITE(3,41) 7187 GO TO 5 71883 I=2*IPD+1 7189 J=I+1 7190 ITMP1=2*IAX+1 7191 ITMP2=ITMP1+1 7192 WRITE(3,38) 7193 IF (RFLD.LT.1.D-20) GO TO 4 7194 EXRM=1./RFLD 7195 EXRA=RFLD/WLAM 7196 EXRA=-360.*(EXRA-AINT(EXRA)) 7197 WRITE(3,39) RFLD,EXRM,EXRA 71984 WRITE(3,40) IGTP(I),IGTP(J),IGAX(ITMP1),IGAX(ITMP2) 71995 IF (IXTYP.EQ.0.OR.IXTYP.EQ.5) GO TO 7 7200 IF (IXTYP.EQ.4) GO TO 6 7201 PRAD=0. 7202 GCON=4.*PI/(1.+XPR6*XPR6) 7203 GCOP=GCON 7204 GO TO 8 72056 PINR=394.51*XPR6*XPR6*WLAM*WLAM 72067 GCOP=WLAM*WLAM*2.*PI/(376.73*PINR) 7207 PRAD=PINR-PLOSS-PNLR 7208 GCON=GCOP 7209 IF (IPD.NE.0) GCON=GCON*PINR/PRAD 72108 I=0 7211 GMAX=-1.E10 7212 PINT=0. 7213 TMP1=DPH*TA 7214 TMP2=.5*DTH*TA 7215 PHI=PHIS-DPH 7216 DO 29 KPH=1,NPH 7217 PHI=PHI+DPH 7218 PHA=PHI*TA 7219 THET=THETS-DTH 7220 DO 29 KTH=1,NTH 7221 THET=THET+DTH 7222 IF (KSYMP.EQ.2.AND.THET.GT.90.01.AND.IFAR.NE.1) GO TO 29 7223 THA=THET*TA 7224 IF (IFAR.EQ.1) GO TO 9 7225 CALL FFLD (THA,PHA,ETH,EPH) 7226 GO TO 10 72279 CALL GFLD (RFLD/WLAM,PHA,THET/WLAM,ETH,EPH,ERD,ZRATI,KSYMP) 7228 ERDM=ABS(ERD) 7229 ERDA=CANG(ERD) 723010 ETHM2=DREAL(ETH*DCONJG(ETH)) 7231 ETHM=SQRT(ETHM2) 7232 ETHA=CANG(ETH) 7233 EPHM2=DREAL(EPH*DCONJG(EPH)) 7234 EPHM=SQRT(EPHM2) 7235 EPHA=CANG(EPH) 7236 IF (IFAR.EQ.1) GO TO 28 7237C ELLIPTICAL POLARIZATION CALC. 7238 IF (ETHM2.GT.1.D-20.OR.EPHM2.GT.1.D-20) GO TO 11 7239 TILTA=0. 7240 EMAJR2=0. 7241 EMINR2=0. 7242 AXRAT=0. 7243 ISENS=HBLK 7244 GO TO 16 724511 DFAZ=EPHA-ETHA 7246 IF (EPHA.LT.0.) GO TO 12 7247 DFAZ2=DFAZ-360. 7248 GO TO 13 724912 DFAZ2=DFAZ+360. 725013 IF (ABS(DFAZ).GT.ABS(DFAZ2)) DFAZ=DFAZ2 7251 CDFAZ=COS(DFAZ*TA) 7252 TSTOR1=ETHM2-EPHM2 7253 TSTOR2=2.*EPHM*ETHM*CDFAZ 7254 TILTA=.5*ATGN2(TSTOR2,TSTOR1) 7255 STILTA=SIN(TILTA) 7256 TSTOR1=TSTOR1*STILTA*STILTA 7257 TSTOR2=TSTOR2*STILTA*COS(TILTA) 7258 EMAJR2=-TSTOR1+TSTOR2+ETHM2 7259 EMINR2=TSTOR1-TSTOR2+EPHM2 7260 IF (EMINR2.LT.0.) EMINR2=0. 7261 AXRAT=SQRT(EMINR2/EMAJR2) 7262 TILTA=TILTA*TD 7263 IF (AXRAT.GT.1.D-5) GO TO 14 7264 ISENS=HPOL(1) 7265 GO TO 16 726614 IF (DFAZ.GT.0.) GO TO 15 7267 ISENS=HPOL(2) 7268 GO TO 16 726915 ISENS=HPOL(3) 727016 GNMJ=DB10(GCON*EMAJR2) 7271 GNMN=DB10(GCON*EMINR2) 7272 GNV=DB10(GCON*ETHM2) 7273 GNH=DB10(GCON*EPHM2) 7274 GTOT=DB10(GCON*(ETHM2+EPHM2)) 7275 IF (INOR.LT.1) GO TO 23 7276 I=I+1 7277 IF (I.GT.NORMAX) GO TO 23 7278 GO TO (17,18,19,20,21), INOR 727917 TSTOR1=GNMJ 7280 GO TO 22 728118 TSTOR1=GNMN 7282 GO TO 22 728319 TSTOR1=GNV 7284 GO TO 22 728520 TSTOR1=GNH 7286 GO TO 22 728721 TSTOR1=GTOT 728822 GAIN(I)=TSTOR1 7289 IF (TSTOR1.GT.GMAX) GMAX=TSTOR1 729023 IF (IAVP.EQ.0) GO TO 24 7291 TSTOR1=GCOP*(ETHM2+EPHM2) 7292 TMP3=THA-TMP2 7293 TMP4=THA+TMP2 7294 IF (KTH.EQ.1) TMP3=THA 7295 IF (KTH.EQ.NTH) TMP4=THA 7296 DA=ABS(TMP1*(COS(TMP3)-COS(TMP4))) 7297 IF (KPH.EQ.1.OR.KPH.EQ.NPH) DA=.5*DA 7298 PINT=PINT+TSTOR1*DA 7299 IF (IAVP.EQ.2) GO TO 29 730024 IF (IAX.EQ.1) GO TO 25 7301 TMP5=GNMJ 7302 TMP6=GNMN 7303 GO TO 26 730425 TMP5=GNV 7305 TMP6=GNH 730626 ETHM=ETHM*WLAM 7307 EPHM=EPHM*WLAM 7308 IF (RFLD.LT.1.D-20) GO TO 27 7309 ETHM=ETHM*EXRM 7310 ETHA=ETHA+EXRA 7311 EPHM=EPHM*EXRM 7312 EPHA=EPHA+EXRA 731327 WRITE(3,42) THET,PHI,TMP5,TMP6,GTOT,AXRAT,TILTA,ISENS,ETHM,ETHA 7314 1,EPHM,EPHA 7315C GO TO 29 7316C*** 7317C28 WRITE(3,43) RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA 7318 IF(IPLP1 .NE. 3) GO TO 299 7319 IF(IPLP3 .EQ. 0) GO TO 290 7320 IF(IPLP2 .EQ. 1 .AND. IPLP3 .EQ. 1) 7321 1WRITE(8,*) THET,ETHM,ETHA 7322 IF(IPLP2 .EQ. 1 .AND. IPLP3 .EQ. 2) 7323 1WRITE(8,*) THET,EPHM,EPHA 7324 IF(IPLP2 .EQ. 2 .AND. IPLP3 .EQ. 1) 7325 1WRITE(8,*) PHI,ETHM,ETHA 7326 IF(IPLP2 .EQ. 2 .AND. IPLP3 .EQ. 2) 7327 1WRITE(8,*) PHI,EPHM,EPHA 7328 IF(IPLP4 .EQ. 0) GO TO 299 7329290 IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 1) 7330 1WRITE(8,*) THET,TMP5 7331 IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 2) 7332 1WRITE(8,*) THET,TMP6 7333 IF(IPLP2 .EQ. 1 .AND. IPLP4 .EQ. 3) 7334 1WRITE(8,*) THET,GTOT 7335 IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 1) 7336 1WRITE(8,*) PHI,TMP5 7337 IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 2) 7338 1WRITE(8,*) PHI,TMP6 7339 IF(IPLP2 .EQ. 2 .AND. IPLP4 .EQ. 3) 7340 1WRITE(8,*) PHI,GTOT 7341 GO TO 299 734228 WRITE(3,43) RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA 7343299 CONTINUE 7344C*** 734529 CONTINUE 7346 IF (IAVP.EQ.0) GO TO 30 7347 TMP3=THETS*TA 7348 TMP4=TMP3+DTH*TA*DFLOAT(NTH-1) 7349 TMP3=ABS(DPH*TA*DFLOAT(NPH-1)*(COS(TMP3)-COS(TMP4))) 7350 PINT=PINT/TMP3 7351 TMP3=TMP3/PI 7352 WRITE(3,44) PINT,TMP3 735330 IF (INOR.EQ.0) GO TO 34 7354 IF (ABS(GNOR).GT.1.D-20) GMAX=GNOR 7355 ITMP1=(INOR-1)*2+1 7356 ITMP2=ITMP1+1 7357 WRITE(3,45) IGNTP(ITMP1),IGNTP(ITMP2),GMAX 7358 ITMP2=NPH*NTH 7359 IF (ITMP2.GT.NORMAX) ITMP2=NORMAX 7360 ITMP1=(ITMP2+2)/3 7361 ITMP2=ITMP1*3-ITMP2 7362 ITMP3=ITMP1 7363 ITMP4=2*ITMP1 7364 IF (ITMP2.EQ.2) ITMP4=ITMP4-1 7365 DO 31 I=1,ITMP1 7366 ITMP3=ITMP3+1 7367 ITMP4=ITMP4+1 7368 J=(I-1)/NTH 7369 TMP1=THETS+DFLOAT(I-J*NTH-1)*DTH 7370 TMP2=PHIS+DFLOAT(J)*DPH 7371 J=(ITMP3-1)/NTH 7372 TMP3=THETS+DFLOAT(ITMP3-J*NTH-1)*DTH 7373 TMP4=PHIS+DFLOAT(J)*DPH 7374 J=(ITMP4-1)/NTH 7375 TMP5=THETS+DFLOAT(ITMP4-J*NTH-1)*DTH 7376 TMP6=PHIS+DFLOAT(J)*DPH 7377 TSTOR1=GAIN(I)-GMAX 7378 IF (I.EQ.ITMP1.AND.ITMP2.NE.0) GO TO 32 7379 TSTOR2=GAIN(ITMP3)-GMAX 7380 PINT=GAIN(ITMP4)-GMAX 738131 WRITE(3,46) TMP1,TMP2,TSTOR1,TMP3,TMP4,TSTOR2,TMP5,TMP6,PINT 7382 GO TO 34 738332 IF (ITMP2.EQ.2) GO TO 33 7384 TSTOR2=GAIN(ITMP3)-GMAX 7385 WRITE(3,46) TMP1,TMP2,TSTOR1,TMP3,TMP4,TSTOR2 7386 GO TO 34 738733 WRITE(3,46) TMP1,TMP2,TSTOR1 738834 RETURN 7389C 739035 FORMAT (///,31X,39H- - - FAR FIELD GROUND PARAMETERS - - -,//) 739136 FORMAT (40X,25HRADIAL WIRE GROUND SCREEN,/,40X,I5,6H WIRES,/,40X,1 7392 12HWIRE LENGTH=,F8.2,7H METERS,/,40X,12HWIRE RADIUS=,1P,E10.3, 7393 27H METERS) 739437 FORMAT (40X,A6,6H CLIFF,/,40X,14HEDGE DISTANCE=,F9.2,7H METERS,/,4 7395 10X,7HHEIGHT=,F8.2,7H METERS,/,40X,15HSECOND MEDIUM -,/,40X,27HRELA 7396 2TIVE DIELECTRIC CONST.=,F7.3,/,40X,13HCONDUCTIVITY=,1P,E10.3, 7397 35H MHOS) 739838 FORMAT (///,48X,30H- - - RADIATION PATTERNS - - -) 739939 FORMAT (54X,6HRANGE=,1P,E13.6,7H METERS,/,54X,12HEXP(-JKR)/R=, 7400 1E12.5,9H AT PHASE,0P,F7.2,8H DEGREES,/) 740140 FORMAT (/,2X,14H- - ANGLES - -,7X,2A6,7HGAINS -,7X,24H- - - POLARI 7402 1ZATION - - -,4X,20H- - - E(THETA) - - -,4X,18H- - - E(PHI) - - -, 7403 2/,2X,5HTHETA,5X,3HPHI,7X,A6,2X,A6,3X,5HTOTAL,6X,5HAXIAL,5X,4HTILT, 7404 33X,5HSENSE,2(5X,9HMAGNITUDE,4X,6HPHASE ),/,2(1X,7HDEGREES,1X),3( 7405 46X,2HDB),8X,5HRATIO,5X,4HDEG.,8X,2(6X,7HVOLTS/M,4X,7HDEGREES)) 740641 FORMAT (///,28X,40H - - - RADIATED FIELDS NEAR GROUND - - -,//,8X, 7407 120H- - - LOCATION - - -,10X,16H- - E(THETA) - -,8X,14H- - E(PHI) - 7408 2 -,8X,17H- - E(RADIAL) - -,/,7X,3HRHO,6X,3HPHI,9X,1HZ,12X,3HMAG,6X 7409 3,5HPHASE,9X,3HMAG,6X,5HPHASE,9X,3HMAG,6X,5HPHASE,/,5X,6HMETERS,3X, 7410 47HDEGREES,4X,6HMETERS,8X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3X,7H 7411 5DEGREES,6X,7HVOLTS/M,3X,7HDEGREES,/) 741242 FORMAT(1X,F7.2,F9.2,3X,3F8.2,F11.5,F9.2,2X,A6,2(1P,E15.5,0P,F9.2)) 741343 FORMAT (3X,F9.2,2X,F7.2,2X,F9.2,1X,3(3X,1P,E11.4,2X,0P,F7.2)) 741444 FORMAT (//,3X,19HAVERAGE POWER GAIN=,1P,E12.5,7X, 31HSOLID ANGLE U 7415 1SED IN AVERAGING=(,0P,F7.4,16H)*PI STERADIANS.,//) 741645 FORMAT (//,37X,31H- - - - NORMALIZED GAIN - - - -,//,37X,2A6,4HGAI 7417 1N,/,38X,22HNORMALIZATION FACTOR =,F9.2,3H DB,//,3(4X,14H- - ANGLES 7418 2 - -,6X,4HGAIN,7X),/,3(4X,5HTHETA,5X,3HPHI,8X,2HDB,8X),/,3(3X,7HDE 7419 3GREES,2X,7HDEGREES,16X)) 742046 FORMAT (3(1X,2F9.2,1X,F9.2,6X)) 7421 END 7422 SUBROUTINE READGM(INUNIT,CODE,I1,I2,R1,R2,R3,R4,R5,R6,R7) 7423C 7424C READGM reads a geometry record and parses it. 7425C 7426C ***** Passed variables 7427C CODE two letter mnemonic code 7428C I1 - I2 integer values from record 7429C R1 - R7 real values from record 7430C 7431 IMPLICIT REAL*8(A-H,O-Z) 7432 CHARACTER*(*) CODE 7433 DIMENSION INTVAL(2),REAVAL(7) 7434C 7435C Call the routine to read the record and parse it. 7436C 7437 CALL PARSIT(INUNIT,2,7,CODE,INTVAL,REAVAL,IEOF) 7438C 7439C Set the return variables to the buffer array elements. 7440C 7441 IF(IEOF.LT.0)CODE='GE' 7442 I1=INTVAL(1) 7443 I2=INTVAL(2) 7444 R1=REAVAL(1) 7445 R2=REAVAL(2) 7446 R3=REAVAL(3) 7447 R4=REAVAL(4) 7448 R5=REAVAL(5) 7449 R6=REAVAL(6) 7450 R7=REAVAL(7) 7451 RETURN 7452 END 7453 SUBROUTINE READMN(INUNIT,CODE,I1,I2,I3,I4,F1,F2,F3,F4,F5,F6) 7454C 7455C READMN reads a control record and parses it. 7456C 7457 IMPLICIT REAL*8(A-H,O-Z) 7458 CHARACTER*(*) CODE 7459 DIMENSION INTVAL(4),REAVAL(6) 7460C 7461C Call the routine to read the record and parse it. 7462C 7463 CALL PARSIT(INUNIT,4,6,CODE,INTVAL,REAVAL,IEOF) 7464C 7465C Set the return variables to the buffer array elements. 7466 IF(IEOF.LT.0)CODE='EN' 7467 I1=INTVAL(1) 7468 I2=INTVAL(2) 7469 I3=INTVAL(3) 7470 I4=INTVAL(4) 7471 F1=REAVAL(1) 7472 F2=REAVAL(2) 7473 F3=REAVAL(3) 7474 F4=REAVAL(4) 7475 F5=REAVAL(5) 7476 F6=REAVAL(6) 7477 RETURN 7478 END 7479 SUBROUTINE PARSIT(INUNIT,MAXINT,MAXREA,CMND,INTFLD,REAFLD,IEOF) 7480 7481C UPDATED: 21 July 87 7482 7483C Called by: READGM READMN 7484 7485C PARSIT reads an input record and parses it. 7486 7487C ***** Passed variables 7488C MAXINT total number of integers in record 7489C MAXREA total number of real values in record 7490C CMND two letter mnemonic code 7491C INTFLD integer values from record 7492C REAFLD real values from record 7493 7494C ***** Internal Variables 7495C BGNFLD list of starting indices 7496C BUFFER text buffer 7497C ENDFLD list of ending indices 7498C FLDTRM flag to indicate that pointer is in field position 7499C REC input line as read 7500C TOTCOL total number of columns in REC 7501C TOTFLD number of numeric fields 7502 IMPLICIT REAL*8(A-H,O-Z) 7503 CHARACTER CMND*2, BUFFER*20, REC*80 7504 INTEGER INTFLD(MAXINT) 7505 INTEGER BGNFLD(12), ENDFLD(12), TOTCOL, TOTFLD 7506 LOGICAL FLDTRM 7507 DIMENSION REAFLD(MAXREA) 7508C 7509 READ(INUNIT, 8000, IOSTAT=IEOF) REC 7510 CALL UPCASE( REC, REC, TOTCOL ) 7511C 7512C Store opcode and clear field arrays. 7513C 7514 CMND= REC(1:2) 7515 DO 3000 I=1,MAXINT 7516 INTFLD(I)= 0 7517 3000 CONTINUE 7518 DO 3010 I=1,MAXREA 7519 REAFLD(I)= 0.0 7520 3010 CONTINUE 7521 DO 3020 I=1,12 7522 BGNFLD(I)= 0 7523 ENDFLD(I)= 0 7524 3020 CONTINUE 7525C 7526C Find the beginning and ending of each field as well as the total number of 7527C fields. 7528C 7529 TOTFLD= 0 7530 FLDTRM= .FALSE. 7531 LAST= MAXREA + MAXINT 7532 DO 4000 J=3,TOTCOL 7533 K= ICHAR( REC(J:J) ) 7534C 7535C Check for end of line comment (`!'). This is a new modification to allow 7536C VAX-like comments at the end of data records, i.e. 7537C GW 1 7 0 0 0 0 0 .5 .0001 ! DIPOLE WIRE 7538C GE ! END OF GEOMETRY 7539C 7540 IF (K .EQ. 33) THEN 7541 IF (FLDTRM) ENDFLD(TOTFLD)= J - 1 7542 GO TO 5000 7543C 7544C Set the ending index when the character is a comma or space and the pointer 7545C is in a field position (FLDTRM = .TRUE.). 7546C 7547 ELSE IF (K .EQ. 32 .OR. K .EQ. 44) THEN 7548 IF (FLDTRM) THEN 7549 ENDFLD(TOTFLD)= J - 1 7550 FLDTRM= .FALSE. 7551 ENDIF 7552C 7553C Set the beginning index when the character is not a comma or space and the 7554C pointer is not currently in a field position (FLDTRM = .FALSE). 7555C 7556 ELSE IF (.NOT. FLDTRM) THEN 7557 TOTFLD= TOTFLD + 1 7558 FLDTRM= .TRUE. 7559 BGNFLD(TOTFLD)= J 7560 ENDIF 7561 4000 CONTINUE 7562 IF (FLDTRM) ENDFLD(TOTFLD)= TOTCOL 7563 7564C Check to see if the total number of value fields is within the precribed 7565C limits. 7566 7567 5000 IF (TOTFLD .EQ. 0) THEN 7568 RETURN 7569 ELSE IF (TOTFLD .GT. LAST) THEN 7570 WRITE(3, 8001 ) 7571 GOTO 9010 7572 ENDIF 7573 J= MIN( TOTFLD, MAXINT ) 7574 7575C Parse out integer values and store into integer buffer array. 7576 7577 DO 5090 I=1,J 7578 LENGTH= ENDFLD(I) - BGNFLD(I) + 1 7579 BUFFER= REC(BGNFLD(I):ENDFLD(I)) 7580 IND= INDEX( BUFFER(1:LENGTH), '.' ) 7581 IF (IND .GT. 0 .AND. IND .LT. LENGTH) GO TO 9000 7582 IF (IND .EQ. LENGTH) LENGTH= LENGTH - 1 7583 READ( BUFFER(1:LENGTH), *, ERR=9000 ) INTFLD(I) 7584 5090 CONTINUE 7585 7586C Parse out real values and store into real buffer array. 7587 7588 IF (TOTFLD .GT. MAXINT) THEN 7589 J= MAXINT + 1 7590 DO 6000 I=J,TOTFLD 7591 LENGTH= ENDFLD(I) - BGNFLD(I) + 1 7592 BUFFER= REC(BGNFLD(I):ENDFLD(I)) 7593 IND= INDEX( BUFFER(1:LENGTH), '.' ) 7594 IF (IND .EQ. 0) THEN 7595 INDE= INDEX( BUFFER(1:LENGTH), 'E' ) 7596 LENGTH= LENGTH + 1 7597 IF (INDE .EQ. 0) THEN 7598 BUFFER(LENGTH:LENGTH)= '.' 7599 ELSE 7600 BUFFER= BUFFER(1:INDE-1)//'.'// 7601 & BUFFER(INDE:LENGTH-1) 7602 ENDIF 7603 ENDIF 7604 READ( BUFFER(1:LENGTH), *, ERR=9000 ) REAFLD(I-MAXINT) 7605 6000 CONTINUE 7606 ENDIF 7607 RETURN 7608 7609C Print out text of record line when error occurs. 7610 7611 9000 IF (I .LE. MAXINT) THEN 7612 WRITE(3, 8002 ) I 7613 ELSE 7614 I= I - MAXINT 7615 WRITE(3, 8003 ) I 7616 ENDIF 7617 9010 WRITE(3, 8004 ) REC 7618 STOP 'CARD ERROR' 7619C 7620C Input formats and output messages. 7621C 7622 8000 FORMAT (A80) 7623 8001 FORMAT (//,' ***** CARD ERROR - TOO MANY FIELDS IN RECORD') 7624 8002 FORMAT (//,' ***** CARD ERROR - INVALID NUMBER AT INTEGER', 7625 & ' POSITION ',I1) 7626 8003 FORMAT (//,' ***** CARD ERROR - INVALID NUMBER AT REAL', 7627 & ' POSITION ',I1) 7628 8004 FORMAT (' ***** TEXT --> ',A80) 7629 END 7630 SUBROUTINE UPCASE( INTEXT, OUTTXT, LENGTH ) 7631C 7632C UPCASE finds the length of INTEXT and converts it to upper case. 7633C 7634 CHARACTER *(*) INTEXT, OUTTXT 7635C 7636C 7637 LENGTH = LEN( INTEXT ) 7638 DO 3000 I=1,LENGTH 7639 J = ICHAR( INTEXT(I:I) ) 7640 IF (J .GE. 96) J = J - 32 7641 OUTTXT(I:I) = CHAR( J ) 7642 3000 CONTINUE 7643 RETURN 7644 END 7645 SUBROUTINE REBLK (B,BX,NB,NBX,N2C) 7646C *** 7647C DOUBLE PRECISION 6/4/85 7648C 7649 IMPLICIT REAL*8(A-H,O-Z) 7650C *** 7651C REBLOCK ARRAY B IN N.G.F. SOLUTION FROM BLOCKS OF ROWS ON TAPE14 7652C TO BLOCKS OF COLUMNS ON TAPE16 7653 COMPLEX*16 B,BX 7654 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 7655 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 7656 DIMENSION B(NB,1), BX(NBX,1) 7657 REWIND 16 7658 NIB=0 7659 NPB=NPBL 7660 DO 3 IB=1,NBBL 7661 IF (IB.EQ.NBBL) NPB=NLBL 7662 REWIND 14 7663 NIX=0 7664 NPX=NPBX 7665 DO 2 IBX=1,NBBX 7666 IF (IBX.EQ.NBBX) NPX=NLBX 7667 READ (14) ((BX(I,J),I=1,NPX),J=1,N2C) 7668 DO 1 I=1,NPX 7669 IX=I+NIX 7670 DO 1 J=1,NPB 76711 B(IX,J)=BX(I,J+NIB) 76722 NIX=NIX+NPBX 7673 WRITE (16) ((B(I,J),I=1,NB),J=1,NPB) 76743 NIB=NIB+NPBL 7675 REWIND 14 7676 REWIND 16 7677 RETURN 7678 END 7679 SUBROUTINE REFLC (IX,IY,IZ,ITX,NOP) 7680C *** 7681C DOUBLE PRECISION 6/4/85 7682C 7683 PARAMETER (MAXSEG=1500, MAXMAT=1500) 7684 IMPLICIT REAL*8(A-H,O-Z) 7685C *** 7686C 7687C REFLC REFLECTS PARTIAL STRUCTURE ALONG X,Y, OR Z AXES OR ROTATES 7688C STRUCTURE TO COMPLETE A SYMMETRIC STRUCTURE. 7689C 7690 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 7691 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 7692 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 7693 COMMON /ANGL/ SALP(MAXSEG) 7694 DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1), X2(1), Y 7695 12(1), Z2(1) 7696 EQUIVALENCE (T1X,SI), (T1Y,ALP), (T1Z,BET), (T2X,ICON1), (T2Y,ICON 7697 12), (T2Z,ITAG), (X2,SI), (Y2,ALP), (Z2,BET) 7698 NP=N 7699 MP=M 7700 IPSYM=0 7701 ITI=ITX 7702 IF (IX.LT.0) GO TO 19 7703 IF (NOP.EQ.0) RETURN 7704 IPSYM=1 7705 IF (IZ.EQ.0) GO TO 6 7706C 7707C REFLECT ALONG Z AXIS 7708C 7709 IPSYM=2 7710 IF (N.LT.N2) GO TO 3 7711 DO 2 I=N2,N 7712 NX=I+N-N1 7713 E1=Z(I) 7714 E2=Z2(I) 7715 IF (ABS(E1)+ABS(E2).GT.1.D-5.AND.E1*E2.GE.-1.D-6) GO TO 1 7716 WRITE(3,24) I 7717 STOP 77181 X(NX)=X(I) 7719 Y(NX)=Y(I) 7720 Z(NX)=-E1 7721 X2(NX)=X2(I) 7722 Y2(NX)=Y2(I) 7723 Z2(NX)=-E2 7724 ITAGI=ITAG(I) 7725 IF (ITAGI.EQ.0) ITAG(NX)=0 7726 IF (ITAGI.NE.0) ITAG(NX)=ITAGI+ITI 77272 BI(NX)=BI(I) 7728 N=N*2-N1 7729 ITI=ITI*2 77303 IF (M.LT.M2) GO TO 6 7731 NXX=LD+1-M1 7732 DO 5 I=M2,M 7733 NXX=NXX-1 7734 NX=NXX-M+M1 7735 IF (ABS(Z(NXX)).GT.1.D-10) GO TO 4 7736 WRITE(3,25) I 7737 STOP 77384 X(NX)=X(NXX) 7739 Y(NX)=Y(NXX) 7740 Z(NX)=-Z(NXX) 7741 T1X(NX)=T1X(NXX) 7742 T1Y(NX)=T1Y(NXX) 7743 T1Z(NX)=-T1Z(NXX) 7744 T2X(NX)=T2X(NXX) 7745 T2Y(NX)=T2Y(NXX) 7746 T2Z(NX)=-T2Z(NXX) 7747 SALP(NX)=-SALP(NXX) 77485 BI(NX)=BI(NXX) 7749 M=M*2-M1 77506 IF (IY.EQ.0) GO TO 12 7751C 7752C REFLECT ALONG Y AXIS 7753C 7754 IF (N.LT.N2) GO TO 9 7755 DO 8 I=N2,N 7756 NX=I+N-N1 7757 E1=Y(I) 7758 E2=Y2(I) 7759 IF (ABS(E1)+ABS(E2).GT.1.D-5.AND.E1*E2.GE.-1.D-6) GO TO 7 7760 WRITE(3,24) I 7761 STOP 77627 X(NX)=X(I) 7763 Y(NX)=-E1 7764 Z(NX)=Z(I) 7765 X2(NX)=X2(I) 7766 Y2(NX)=-E2 7767 Z2(NX)=Z2(I) 7768 ITAGI=ITAG(I) 7769 IF (ITAGI.EQ.0) ITAG(NX)=0 7770 IF (ITAGI.NE.0) ITAG(NX)=ITAGI+ITI 77718 BI(NX)=BI(I) 7772 N=N*2-N1 7773 ITI=ITI*2 77749 IF (M.LT.M2) GO TO 12 7775 NXX=LD+1-M1 7776 DO 11 I=M2,M 7777 NXX=NXX-1 7778 NX=NXX-M+M1 7779 IF (ABS(Y(NXX)).GT.1.D-10) GO TO 10 7780 WRITE(3,25) I 7781 STOP 778210 X(NX)=X(NXX) 7783 Y(NX)=-Y(NXX) 7784 Z(NX)=Z(NXX) 7785 T1X(NX)=T1X(NXX) 7786 T1Y(NX)=-T1Y(NXX) 7787 T1Z(NX)=T1Z(NXX) 7788 T2X(NX)=T2X(NXX) 7789 T2Y(NX)=-T2Y(NXX) 7790 T2Z(NX)=T2Z(NXX) 7791 SALP(NX)=-SALP(NXX) 779211 BI(NX)=BI(NXX) 7793 M=M*2-M1 779412 IF (IX.EQ.0) GO TO 18 7795C 7796C REFLECT ALONG X AXIS 7797C 7798 IF (N.LT.N2) GO TO 15 7799 DO 14 I=N2,N 7800 NX=I+N-N1 7801 E1=X(I) 7802 E2=X2(I) 7803 IF (ABS(E1)+ABS(E2).GT.1.D-5.AND.E1*E2.GE.-1.D-6) GO TO 13 7804 WRITE(3,24) I 7805 STOP 780613 X(NX)=-E1 7807 Y(NX)=Y(I) 7808 Z(NX)=Z(I) 7809 X2(NX)=-E2 7810 Y2(NX)=Y2(I) 7811 Z2(NX)=Z2(I) 7812 ITAGI=ITAG(I) 7813 IF (ITAGI.EQ.0) ITAG(NX)=0 7814 IF (ITAGI.NE.0) ITAG(NX)=ITAGI+ITI 781514 BI(NX)=BI(I) 7816 N=N*2-N1 781715 IF (M.LT.M2) GO TO 18 7818 NXX=LD+1-M1 7819 DO 17 I=M2,M 7820 NXX=NXX-1 7821 NX=NXX-M+M1 7822 IF (ABS(X(NXX)).GT.1.D-10) GO TO 16 7823 WRITE(3,25) I 7824 STOP 782516 X(NX)=-X(NXX) 7826 Y(NX)=Y(NXX) 7827 Z(NX)=Z(NXX) 7828 T1X(NX)=-T1X(NXX) 7829 T1Y(NX)=T1Y(NXX) 7830 T1Z(NX)=T1Z(NXX) 7831 T2X(NX)=-T2X(NXX) 7832 T2Y(NX)=T2Y(NXX) 7833 T2Z(NX)=T2Z(NXX) 7834 SALP(NX)=-SALP(NXX) 783517 BI(NX)=BI(NXX) 7836 M=M*2-M1 783718 RETURN 7838C 7839C REPRODUCE STRUCTURE WITH ROTATION TO FORM CYLINDRICAL STRUCTURE 7840C 784119 FNOP=NOP 7842 IPSYM=-1 7843 SAM=6.283185308D+0/FNOP 7844 CS=COS(SAM) 7845 SS=SIN(SAM) 7846 IF (N.LT.N2) GO TO 21 7847 N=N1+(N-N1)*NOP 7848 NX=NP+1 7849 DO 20 I=NX,N 7850 K=I-NP+N1 7851 XK=X(K) 7852 YK=Y(K) 7853 X(I)=XK*CS-YK*SS 7854 Y(I)=XK*SS+YK*CS 7855 Z(I)=Z(K) 7856 XK=X2(K) 7857 YK=Y2(K) 7858 X2(I)=XK*CS-YK*SS 7859 Y2(I)=XK*SS+YK*CS 7860 Z2(I)=Z2(K) 7861 ITAGI=ITAG(K) 7862 IF (ITAGI.EQ.0) ITAG(I)=0 7863 IF (ITAGI.NE.0) ITAG(I)=ITAGI+ITI 786420 BI(I)=BI(K) 786521 IF (M.LT.M2) GO TO 23 7866 M=M1+(M-M1)*NOP 7867 NX=MP+1 7868 K=LD+1-M1 7869 DO 22 I=NX,M 7870 K=K-1 7871 J=K-MP+M1 7872 XK=X(K) 7873 YK=Y(K) 7874 X(J)=XK*CS-YK*SS 7875 Y(J)=XK*SS+YK*CS 7876 Z(J)=Z(K) 7877 XK=T1X(K) 7878 YK=T1Y(K) 7879 T1X(J)=XK*CS-YK*SS 7880 T1Y(J)=XK*SS+YK*CS 7881 T1Z(J)=T1Z(K) 7882 XK=T2X(K) 7883 YK=T2Y(K) 7884 T2X(J)=XK*CS-YK*SS 7885 T2Y(J)=XK*SS+YK*CS 7886 T2Z(J)=T2Z(K) 7887 SALP(J)=SALP(K) 788822 BI(J)=BI(K) 788923 RETURN 7890C 789124 FORMAT (29H GEOMETRY DATA ERROR--SEGMENT,I5,26H LIES IN PLANE OF S 7892 1YMMETRY) 789325 FORMAT (27H GEOMETRY DATA ERROR--PATCH,I4,26H LIES IN PLANE OF SYM 7894 1METRY) 7895 END 7896 SUBROUTINE ROM2 (A,B,SUM,DMIN) 7897C *** 7898C DOUBLE PRECISION 6/4/85 7899C 7900 IMPLICIT REAL*8(A-H,O-Z) 7901C *** 7902C 7903C FOR THE SOMMERFELD GROUND OPTION, ROM2 INTEGRATES OVER THE SOURCE 7904C SEGMENT TO OBTAIN THE TOTAL FIELD DUE TO GROUND. THE METHOD OF 7905C VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION IS USED. THERE ARE 9 7906C FIELD COMPONENTS - THE X, Y, AND Z COMPONENTS DUE TO CONSTANT, 7907C SINE, AND COSINE CURRENT DISTRIBUTIONS. 7908C 7909 COMPLEX*16 SUM,G1,G2,G3,G4,G5,T00,T01,T10,T02,T11,T20 7910 DIMENSION SUM(9), G1(9), G2(9), G3(9), G4(9), G5(9), T01(9), T10(9 7911 1), T20(9) 7912 DATA NM,NTS,NX,N/65536,4,1,9/,RX/1.D-4/ 7913 Z=A 7914 ZE=B 7915 S=B-A 7916 IF (S.GE.0.) GO TO 1 7917 WRITE(3,18) 7918 STOP 79191 EP=S/(1.E4*NM) 7920 ZEND=ZE-EP 7921 DO 2 I=1,N 79222 SUM(I)=(0.,0.) 7923 NS=NX 7924 NT=0 7925 CALL SFLDS (Z,G1) 79263 DZ=S/NS 7927 IF (Z+DZ.LE.ZE) GO TO 4 7928 DZ=ZE-Z 7929 IF (DZ.LE.EP) GO TO 17 79304 DZOT=DZ*.5 7931 CALL SFLDS (Z+DZOT,G3) 7932 CALL SFLDS (Z+DZ,G5) 79335 TMAG1=0. 7934 TMAG2=0. 7935C 7936C EVALUATE 3 POINT ROMBERG RESULT AND TEST CONVERGENCE. 7937C 7938 DO 6 I=1,N 7939 T00=(G1(I)+G5(I))*DZOT 7940 T01(I)=(T00+DZ*G3(I))*.5 7941 T10(I)=(4.*T01(I)-T00)/3. 7942 IF (I.GT.3) GO TO 6 7943 TR=DREAL(T01(I)) 7944 TI=DIMAG(T01(I)) 7945 TMAG1=TMAG1+TR*TR+TI*TI 7946 TR=DREAL(T10(I)) 7947 TI=DIMAG(T10(I)) 7948 TMAG2=TMAG2+TR*TR+TI*TI 79496 CONTINUE 7950 TMAG1=SQRT(TMAG1) 7951 TMAG2=SQRT(TMAG2) 7952 CALL TEST(TMAG1,TMAG2,TR,0.D0,0.D0,TI,DMIN) 7953 IF(TR.GT.RX)GO TO 8 7954 DO 7 I=1,N 79557 SUM(I)=SUM(I)+T10(I) 7956 NT=NT+2 7957 GO TO 12 79588 CALL SFLDS (Z+DZ*.25,G2) 7959 CALL SFLDS (Z+DZ*.75,G4) 7960 TMAG1=0. 7961 TMAG2=0. 7962C 7963C EVALUATE 5 POINT ROMBERG RESULT AND TEST CONVERGENCE. 7964C 7965 DO 9 I=1,N 7966 T02=(T01(I)+DZOT*(G2(I)+G4(I)))*.5 7967 T11=(4.*T02-T01(I))/3. 7968 T20(I)=(16.*T11-T10(I))/15. 7969 IF (I.GT.3) GO TO 9 7970 TR=DREAL(T11) 7971 TI=DIMAG(T11) 7972 TMAG1=TMAG1+TR*TR+TI*TI 7973 TR=DREAL(T20(I)) 7974 TI=DIMAG(T20(I)) 7975 TMAG2=TMAG2+TR*TR+TI*TI 79769 CONTINUE 7977 TMAG1=SQRT(TMAG1) 7978 TMAG2=SQRT(TMAG2) 7979 CALL TEST(TMAG1,TMAG2,TR,0.D0,0.D0,TI,DMIN) 7980 IF(TR.GT.RX)GO TO 14 798110 DO 11 I=1,N 798211 SUM(I)=SUM(I)+T20(I) 7983 NT=NT+1 798412 Z=Z+DZ 7985 IF (Z.GT.ZEND) GO TO 17 7986 DO 13 I=1,N 798713 G1(I)=G5(I) 7988 IF (NT.LT.NTS.OR.NS.LE.NX) GO TO 3 7989 NS=NS/2 7990 NT=1 7991 GO TO 3 799214 NT=0 7993 IF (NS.LT.NM) GO TO 15 7994 WRITE(3,19) Z 7995 GO TO 10 799615 NS=NS*2 7997 DZ=S/NS 7998 DZOT=DZ*.5 7999 DO 16 I=1,N 8000 G5(I)=G3(I) 800116 G3(I)=G2(I) 8002 GO TO 5 800317 CONTINUE 8004 RETURN 8005C 800618 FORMAT (30H ERROR - B LESS THAN A IN ROM2) 800719 FORMAT (33H ROM2 -- STEP SIZE LIMITED AT Z =,1P,E12.5) 8008 END 8009 SUBROUTINE SBF (I,IS,AA,BB,CC) 8010C *** 8011C DOUBLE PRECISION 6/4/85 8012C 8013 PARAMETER (MAXSEG=1500, MAXMAT=1500) 8014 IMPLICIT REAL*8(A-H,O-Z) 8015C *** 8016C COMPUTE COMPONENT OF BASIS FUNCTION I ON SEGMENT IS. 8017 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 8018 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 8019 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 8020 DATA PI/3.141592654D+0/,JMAX/30/ 8021 AA=0. 8022 BB=0. 8023 CC=0. 8024 JUNE=0 8025 JSNO=0 8026 PP=0. 8027 JCOX=ICON1(I) 8028 IF (JCOX.GT.10000) JCOX=I 8029 JEND=-1 8030 IEND=-1 8031 SIG=-1. 8032 IF (JCOX) 1,11,2 80331 JCOX=-JCOX 8034 GO TO 3 80352 SIG=-SIG 8036 JEND=-JEND 80373 JSNO=JSNO+1 8038 IF (JSNO.GE.JMAX) GO TO 24 8039 D=PI*SI(JCOX) 8040 SDH=SIN(D) 8041 CDH=COS(D) 8042 SD=2.*SDH*CDH 8043 IF (D.GT.0.015) GO TO 4 8044 OMC=4.*D*D 8045 OMC=((1.3888889D-3*OMC-4.1666666667D-2)*OMC+.5)*OMC 8046 GO TO 5 80474 OMC=1.-CDH*CDH+SDH*SDH 80485 AJ=1./(LOG(1./(PI*BI(JCOX)))-.577215664D+0) 8049 PP=PP-OMC/SD*AJ 8050 IF (JCOX.NE.IS) GO TO 6 8051 AA=AJ/SD*SIG 8052 BB=AJ/(2.*CDH) 8053 CC=-AJ/(2.*SDH)*SIG 8054 JUNE=IEND 80556 IF (JCOX.EQ.I) GO TO 9 8056 IF (JEND.EQ.1) GO TO 7 8057 JCOX=ICON1(JCOX) 8058 GO TO 8 80597 JCOX=ICON2(JCOX) 80608 IF (IABS(JCOX).EQ.I) GO TO 10 8061 IF (JCOX) 1,24,2 80629 IF (JCOX.EQ.IS) BB=-BB 806310 IF (IEND.EQ.1) GO TO 12 806411 PM=-PP 8065 PP=0. 8066 NJUN1=JSNO 8067 JCOX=ICON2(I) 8068 IF (JCOX.GT.10000) JCOX=I 8069 JEND=1 8070 IEND=1 8071 SIG=-1. 8072 IF (JCOX) 1,12,2 807312 NJUN2=JSNO-NJUN1 8074 D=PI*SI(I) 8075 SDH=SIN(D) 8076 CDH=COS(D) 8077 SD=2.*SDH*CDH 8078 CD=CDH*CDH-SDH*SDH 8079 IF (D.GT.0.015) GO TO 13 8080 OMC=4.*D*D 8081 OMC=((1.3888889D-3*OMC-4.1666666667D-2)*OMC+.5)*OMC 8082 GO TO 14 808313 OMC=1.-CD 808414 AP=1./(LOG(1./(PI*BI(I)))-.577215664D+0) 8085 AJ=AP 8086 IF (NJUN1.EQ.0) GO TO 19 8087 IF (NJUN2.EQ.0) GO TO 21 8088 QP=SD*(PM*PP+AJ*AP)+CD*(PM*AP-PP*AJ) 8089 QM=(AP*OMC-PP*SD)/QP 8090 QP=-(AJ*OMC+PM*SD)/QP 8091 IF (JUNE) 15,18,16 809215 AA=AA*QM 8093 BB=BB*QM 8094 CC=CC*QM 8095 GO TO 17 809616 AA=-AA*QP 8097 BB=BB*QP 8098 CC=-CC*QP 809917 IF (I.NE.IS) RETURN 810018 AA=AA-1. 8101 BB=BB+(AJ*QM+AP*QP)*SDH/SD 8102 CC=CC+(AJ*QM-AP*QP)*CDH/SD 8103 RETURN 810419 IF (NJUN2.EQ.0) GO TO 23 8105 QP=PI*BI(I) 8106 XXI=QP*QP 8107 XXI=QP*(1.-.5*XXI)/(1.-XXI) 8108 QP=-(OMC+XXI*SD)/(SD*(AP+XXI*PP)+CD*(XXI*AP-PP)) 8109 IF (JUNE.NE.1) GO TO 20 8110 AA=-AA*QP 8111 BB=BB*QP 8112 CC=-CC*QP 8113 IF (I.NE.IS) RETURN 811420 AA=AA-1. 8115 D=CD-XXI*SD 8116 BB=BB+(SDH+AP*QP*(CDH-XXI*SDH))/D 8117 CC=CC+(CDH+AP*QP*(SDH+XXI*CDH))/D 8118 RETURN 811921 QM=PI*BI(I) 8120 XXI=QM*QM 8121 XXI=QM*(1.-.5*XXI)/(1.-XXI) 8122 QM=(OMC+XXI*SD)/(SD*(AJ-XXI*PM)+CD*(PM+XXI*AJ)) 8123 IF (JUNE.NE.-1) GO TO 22 8124 AA=AA*QM 8125 BB=BB*QM 8126 CC=CC*QM 8127 IF (I.NE.IS) RETURN 812822 AA=AA-1. 8129 D=CD-XXI*SD 8130 BB=BB+(AJ*QM*(CDH-XXI*SDH)-SDH)/D 8131 CC=CC+(CDH-AJ*QM*(SDH+XXI*CDH))/D 8132 RETURN 813323 AA=-1. 8134 QP=PI*BI(I) 8135 XXI=QP*QP 8136 XXI=QP*(1.-.5*XXI)/(1.-XXI) 8137 CC=1./(CDH-XXI*SDH) 8138 RETURN 813924 WRITE(3,25) I 8140 STOP 8141C 814225 FORMAT (43H SBF - SEGMENT CONNECTION ERROR FOR SEGMENT,I5) 8143 END 8144 SUBROUTINE SECONDS (CPUSECD) 8145C 8146C Purpose: 8147C SECOND returns cpu time in seconds. Must be customized!!! 8148C 8149C VAX or other (modify subroutine stopwtch): 8150C 8151 REAL*8 CPUSECD 8152 CALL STOPWTCH(CPUSECS,WALLTOT,CPUSPLT,WALLSPLT) 8153 CPUSECD=60.*CPUSECS 8154C MACINTOSH: 8155C CPUSECD= LONG(362)/60.0 8156 RETURN 8157 END 8158c ********************************************************************** 8159 subroutine stopwtch(cputot,walltot,cpusplt,wallsplt) 8160c 8161c This routine operates as a stopwatch. 8162c When first called, the routine initializes the clock. 8163c On subsequent calls, the routine returns: 8164c 8165c Outputs: cputot -- elapsed CPU time since initialization 8166c walltot -- elapsed wallclock time since initialization 8167c cpusplt -- split (delta) CPU time since previous call 8168c wallsplt -- split wallclock time since previous call 8169c 8170c These outputs will all be zero (or very close to it) on the 8171c first (initialization) call. 8172c 8173c Internal times (cpuinit,wallinit,cpunow,wallnow) are stored in 8174c seconds. cpuinit and cpunow are stored as reals, 8175c wallinit and wallnow are stored as integers. 8176c Output times are converted to real minutes. 8177c 8178c History: 8179c Date Author Reason 8180c --------- ---------------- ------------------------------------ 8181c early-90 Scott L. Ray initial version 8182c mid-90 Scott L. Ray support for additional machines 8183c 14-JAN-91 ---- Version 2.2/release ---- 8184c 23-MAY-91 Scott L. Ray UNICOS branch 8185c 29-JAN-92 Scott L. Ray FPS and NLTSS support dropped 8186c 29-JAN-92 Scott L. Ray switch to cpp conditional compilation 8187c 18-SEP-92 Conditional compilation disabled for use in NEC 8188c 8189c (C) Copyright 1990, 1992. 8190c The Regents of the University of California. All rights reserved. 8191c ---------------------------------------------------------------------- 8192c 8193c parameter list 8194c 8195 real cputot,walltot,cpusplt,wallsplt 8196c 8197c locals (non sysdep) 8198c 8199 logical initiz 8200 integer wallinit,walllast,wallnow 8201 real cpuinit,cpulast,cpunow 8202 save initiz,cpuinit,cpulast,wallinit,walllast 8203c 8204c locals (sysdep) 8205c 8206C#include "machines.h" 8207C#ifdef VAX_VMS 8208C integer istatus,iwall,icpu 8209C real rwall 8210C dimension iwall(2) 8211C#endif 8212C#ifdef SUN4TIMER 8213 integer time 8214 real tarray 8215 dimension tarray(2) 8216C#endif 8217C#ifdef CONVEX 8218C real time, secnds, tarray 8219C dimension tarray(2) 8220C external secnds 8221C#endif 8222C#ifdef IBM_RISC 8223c integer icpu 8224c integer mclock 8225C#endif 8226C#ifdef IRIS4D 8227C external time 8228C#endif 8229C#ifdef STARDENT 8230C integer stime 8231C real tarray 8232C dimension tarray(2) 8233C#endif 8234C#ifdef UNICOS 8235C real rwall 8236C#endif 8237c 8238c data initialization 8239c 8240 data initiz/.false./ 8241c 8242c ---------------------------------------------------------------------- 8243c 8244 if (.not. initiz) then 8245c 8246c ... set the flag showing that the clock has been initialized 8247c 8248 initiz = .true. 8249c 8250c ... set the initial times to default value of zero. These may 8251c be changed, depending on how an individual machine handles 8252c its timer. 8253c 8254 cpuinit = 0.0 8255 wallinit = 0 8256c 8257c ... initialize the timer (may not be necessary on all machines) 8258c 8259C#ifdef VAX_VMS 8260C istatus = lib$init_timer() 8261C#endif 8262c 8263C#ifdef SUN4TIMER 8264c CPU timer on SUN4 initializes automatically on job startup. 8265c However, we want t=0 to be defined when this routine is first 8266c called. Hence, define initial CPU time here. 8267c Wall clock timer counts in seconds from 1-Jan-70 Thus, 8268c initial wall clock time is non-zero. It is obtained here. 8269c 8270 cpuinit = etime(tarray) 8271 wallinit = time() 8272C#endif 8273c 8274C#ifdef CONVEX 8275C cpuinit = etime(tarray) 8276C time = secnds(0.0) 8277C wallinit = ifix(time) 8278C#endif 8279c 8280C#ifdef IBM_RISC 8281c no known wall clock timer 8282c 8283c icpu = mclock( ) 8284c cpuinit = float(icpu)/100.0 8285c wallinit = 0 8286C#endif 8287c 8288C#ifdef STARDENT 8289c CPU timer on STARDENT initializes automatically on job 8290c startup. 8291c However, we want t=0 to be defined when this routine is first 8292c called. Hence, define initial CPU time here. 8293c Wall clock timer counts in seconds from 1-Jan-70 Thus, 8294c initial wall clock time is non-zero. It is obtained here. 8295c 8296C cpuinit = etime(tarray) 8297C wallinit = stime() 8298C#endif 8299c 8300C#ifdef UNICOS 8301c I hope that the "second" routine is true UNICOS and not a 8302c local (LLNL) feature that was added on to keep things 8303c consistent with NLTSS. 8304c The "timef" routine returns real milliseconds; first 8305c call initializes the timer and should return zero (not 8306c that we care -- this routine works by taking differences). 8307c 8308C call second(cpuinit) 8309C call timef(rwall) 8310C wallinit = ifix(rwall*1.0e-03) 8311C#endif 8312c 8313c ... since this is the first call to this routine, 8314c initialize the previous call times to the initial time. 8315c 8316 cpulast = cpuinit 8317 walllast = wallinit 8318c 8319 end if 8320c 8321c ... Find the current cpu and wall times 8322c 8323C#ifdef HASTIMER 8324C#ifdef VAX_VMS 8325c 8326c function "lib$stat_timer" is called as: 8327c error_status = lib$stat_timer(input_code,output_result,junk) 8328c where, 8329c input_code = 1 returns elapsed wall clock time in VAX_VMS 8330c binary internal format. This format takes 64 bits to store, 8331c hence output_result should be a 32 bit integer array of 8332c length 2. 8333c This internal format is converted to a floating point number 8334c by calling "lib$cvtf_from_internal_time". This function 8335c is poorly documented in the VAX_VMS manuals. Here are some 8336c details: First argument = 28 ==> result in real hours 8337c = 29 ==> result in real minutes 8338c = 30 ==> result in real seconds 8339c The input to "lib$cvtf_from_internal_time" goes in the 3rd 8340c argument, the result is returned in the 2nd argument. 8341c input_code = 2 returns elapsed cpu time as an integer in 8342c units of 10msec. This is converted to seconds here. 8343c 8344C istatus = lib$stat_timer(1,iwall,) 8345C istatus = lib$cvtf_from_internal_time(30,rwall,iwall) 8346C wallnow = rwall 8347C istatus = lib$stat_timer(2,icpu,) 8348C cpunow = icpu*(10.0e-3) 8349C#endif 8350c 8351C#ifdef SUN4TIMER 8352c there is some ambiguity in the manual as to how to use 8353c etime. Function returns: 8354c "elapsed execution time" = tarray(1) + tarray(2) 8355c = user time + system time 8356c I am uncertain whether to let cpunow = return value or 8357c else tarray(1). 8358c 8359 cpunow = etime(tarray) 8360 wallnow = time() 8361C#endif 8362c 8363C#ifdef CONVEX 8364C cpunow = etime(tarray) 8365C time = secnds(0.0) 8366C wallnow = ifix(time) 8367C#endif 8368c 8369C#ifdef IBM_RISC 8370c no known wall clock timer 8371c 8372c icpu = mclock( ) 8373c cpunow = float(icpu)/100.0 8374c wallnow = 0 8375C#endif 8376c 8377C#ifdef STARDENT 8378c there is some ambiguity in the manual as to how to use 8379c etime. Function returns: 8380c "elapsed execution time" = tarray(1) + tarray(2) 8381c = user time + system time 8382c I am uncertain whether to let cpunow = return value or 8383c else tarray(1). 8384c 8385C cpunow = etime(tarray) 8386C wallnow = stime() 8387C#endif 8388c 8389C#ifdef UNICOS 8390c I hope that the "second" routine is true UNICOS and not a 8391c local (LLNL) feature that was added on to keep things 8392c consistent with NLTSS. 8393c The "timef" routine returns real milliseconds. 8394c 8395C call second(cpunow) 8396C call timef(rwall) 8397C wallnow = ifix(rwall*1.0e-03) 8398C#endif 8399C#else 8400c for machines without timers or with unknown timers, 8401c set things to zero now to ensure that something is returned 8402C cpunow = 0.0 8403C wallnow = 0 8404C#endif 8405c 8406c ... calculate elapsed and split cpu and wall clock times, 8407c convert to minutes on output. 8408c 8409 cputot = (cpunow - cpuinit )/60.0 8410 walltot = float(wallnow - wallinit)/60.0 8411 cpusplt = (cpunow - cpulast )/60.0 8412 wallsplt = float(wallnow - walllast)/60.0 8413c 8414c ... save "now" times in "last" times 8415c 8416 cpulast = cpunow 8417 walllast = wallnow 8418c 8419 return 8420c ********************************************************************** 8421 end 8422 SUBROUTINE SFLDS (T,E) 8423C *** 8424C DOUBLE PRECISION 6/4/85 8425C 8426 IMPLICIT REAL*8(A-H,O-Z) 8427C *** 8428C 8429C SFLDX RETURNS THE FIELD DUE TO GROUND FOR A CURRENT ELEMENT ON 8430C THE SOURCE SEGMENT AT T RELATIVE TO THE SEGMENT CENTER. 8431C 8432 COMPLEX*16 E,ERV,EZV,ERH,EZH,EPH,T1,EXK,EYK,EZK,EXS,EYS,EZS,EXC 8433 1,EYC,EZC,XX1,XX2,U,U2,ZRATI,ZRATI2,FRATI,ER,ET,HRV,HZV,HRH 8434 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 8435 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 8436 COMMON /INCOM/ XO,YO,ZO,SN,XSN,YSN,ISNOR 8437 COMMON /GWAV/ U,U2,XX1,XX2,R1,R2,ZMH,ZPH 8438 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 8439 &KSYMP,IFAR,IPERF 8440 DIMENSION E(9) 8441 DATA PI/3.141592654D+0/,TP/6.283185308D+0/,POT/1.570796327D+0/ 8442 XT=XJ+T*CABJ 8443 YT=YJ+T*SABJ 8444 ZT=ZJ+T*SALPJ 8445 RHX=XO-XT 8446 RHY=YO-YT 8447 RHS=RHX*RHX+RHY*RHY 8448 RHO=SQRT(RHS) 8449 IF (RHO.GT.0.) GO TO 1 8450 RHX=1. 8451 RHY=0. 8452 PHX=0. 8453 PHY=1. 8454 GO TO 2 84551 RHX=RHX/RHO 8456 RHY=RHY/RHO 8457 PHX=-RHY 8458 PHY=RHX 84592 CPH=RHX*XSN+RHY*YSN 8460 SPH=RHY*XSN-RHX*YSN 8461 IF (ABS(CPH).LT.1.D-10) CPH=0. 8462 IF (ABS(SPH).LT.1.D-10) SPH=0. 8463 ZPH=ZO+ZT 8464 ZPHS=ZPH*ZPH 8465 R2S=RHS+ZPHS 8466 R2=SQRT(R2S) 8467 RK=R2*TP 8468 XX2=DCMPLX(COS(RK),-SIN(RK)) 8469 IF (ISNOR.EQ.1) GO TO 3 8470C 8471C USE NORTON APPROXIMATION FOR FIELD DUE TO GROUND. CURRENT IS 8472C LUMPED AT SEGMENT CENTER WITH CURRENT MOMENT FOR CONSTANT, SINE, 8473C OR COSINE DISTRIBUTION. 8474C 8475 ZMH=1. 8476 R1=1. 8477 XX1=0. 8478 CALL GWAVE (ERV,EZV,ERH,EZH,EPH) 8479 ET=-(0.,4.77134)*FRATI*XX2/(R2S*R2) 8480 ER=2.*ET*DCMPLX(1.D+0,RK) 8481 ET=ET*DCMPLX(1.D+0-RK*RK,RK) 8482 HRV=(ER+ET)*RHO*ZPH/R2S 8483 HZV=(ZPHS*ER-RHS*ET)/R2S 8484 HRH=(RHS*ER-ZPHS*ET)/R2S 8485 ERV=ERV-HRV 8486 EZV=EZV-HZV 8487 ERH=ERH+HRH 8488 EZH=EZH+HRV 8489 EPH=EPH+ET 8490 ERV=ERV*SALPJ 8491 EZV=EZV*SALPJ 8492 ERH=ERH*SN*CPH 8493 EZH=EZH*SN*CPH 8494 EPH=EPH*SN*SPH 8495 ERH=ERV+ERH 8496 E(1)=(ERH*RHX+EPH*PHX)*S 8497 E(2)=(ERH*RHY+EPH*PHY)*S 8498 E(3)=(EZV+EZH)*S 8499 E(4)=0. 8500 E(5)=0. 8501 E(6)=0. 8502 SFAC=PI*S 8503 SFAC=SIN(SFAC)/SFAC 8504 E(7)=E(1)*SFAC 8505 E(8)=E(2)*SFAC 8506 E(9)=E(3)*SFAC 8507 RETURN 8508C 8509C INTERPOLATE IN SOMMERFELD FIELD TABLES 8510C 85113 IF (RHO.LT.1.D-12) GO TO 4 8512 THET=ATAN(ZPH/RHO) 8513 GO TO 5 85144 THET=POT 85155 CALL INTRP (R2,THET,ERV,EZV,ERH,EPH) 8516C COMBINE VERTICAL AND HORIZONTAL COMPONENTS AND CONVERT TO X,Y,Z 8517C COMPONENTS. MULTIPLY BY EXP(-JKR)/R. 8518 XX2=XX2/R2 8519 SFAC=SN*CPH 8520 ERH=XX2*(SALPJ*ERV+SFAC*ERH) 8521 EZH=XX2*(SALPJ*EZV-SFAC*ERV) 8522 EPH=SN*SPH*XX2*EPH 8523C X,Y,Z FIELDS FOR CONSTANT CURRENT 8524 E(1)=ERH*RHX+EPH*PHX 8525 E(2)=ERH*RHY+EPH*PHY 8526 E(3)=EZH 8527 RK=TP*T 8528C X,Y,Z FIELDS FOR SINE CURRENT 8529 SFAC=SIN(RK) 8530 E(4)=E(1)*SFAC 8531 E(5)=E(2)*SFAC 8532 E(6)=E(3)*SFAC 8533C X,Y,Z FIELDS FOR COSINE CURRENT 8534 SFAC=COS(RK) 8535 E(7)=E(1)*SFAC 8536 E(8)=E(2)*SFAC 8537 E(9)=E(3)*SFAC 8538 RETURN 8539 END 8540 SUBROUTINE SOLGF (A,B,C,D,XY,IP,NP,N1,N,MP,M1,M,N1C,N2C,N2CZ) 8541C *** 8542C DOUBLE PRECISION 6/4/85 8543C 8544 PARAMETER (MAXSEG=1500, MAXMAT=1500) 8545 IMPLICIT REAL*8(A-H,O-Z) 8546C *** 8547C SOLVE FOR CURRENT IN N.G.F. PROCEDURE 8548 COMPLEX*16 A,B,C,D,SUM,XY,Y 8549 COMMON /SCRATM/ Y(2*MAXSEG) 8550 COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP 8551 1CON(10),NPCON 8552 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 8553 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 8554 DIMENSION A(1), B(N1C,1), C(N1C,1), D(N2CZ,1), IP(1), XY(1) 8555 IFL=14 8556 IF (ICASX.GT.0) IFL=13 8557 IF (N2C.GT.0) GO TO 1 8558C NORMAL SOLUTION. NOT N.G.F. 8559 CALL SOLVES (A,IP,XY,N1C,1,NP,N,MP,M,13,IFL) 8560 GO TO 22 85611 IF (N1.EQ.N.OR.M1.EQ.0) GO TO 5 8562C REORDER EXCITATION ARRAY 8563 N2=N1+1 8564 JJ=N+1 8565 NPM=N+2*M1 8566 DO 2 I=N2,NPM 85672 Y(I)=XY(I) 8568 J=N1 8569 DO 3 I=JJ,NPM 8570 J=J+1 85713 XY(J)=Y(I) 8572 DO 4 I=N2,N 8573 J=J+1 85744 XY(J)=Y(I) 85755 NEQS=NSCON+2*NPCON 8576 IF (NEQS.EQ.0) GO TO 7 8577 NEQ=N1C+N2C 8578 NEQS=NEQ-NEQS+1 8579C COMPUTE INV(A)E1 8580 DO 6 I=NEQS,NEQ 85816 XY(I)=(0.,0.) 85827 CALL SOLVES (A,IP,XY,N1C,1,NP,N1,MP,M1,13,IFL) 8583 NI=0 8584 NPB=NPBL 8585C COMPUTE E2-C(INV(A)E1) 8586 DO 10 JJ=1,NBBL 8587 IF (JJ.EQ.NBBL) NPB=NLBL 8588 IF (ICASX.GT.1) READ (15) ((C(I,J),I=1,N1C),J=1,NPB) 8589 II=N1C+NI 8590 DO 9 I=1,NPB 8591 SUM=(0.,0.) 8592 DO 8 J=1,N1C 85938 SUM=SUM+C(J,I)*XY(J) 8594 J=II+I 85959 XY(J)=XY(J)-SUM 859610 NI=NI+NPBL 8597 IF (ICASX.GT.1) REWIND 15 8598 JJ=N1C+1 8599C COMPUTE INV(D)(E2-C(INV(A)E1)) = I2 8600 IF (ICASX.GT.1) GO TO 11 8601 CALL SOLVE (N2C,D,IP(JJ),XY(JJ),N2C) 8602 GO TO 13 860311 IF (ICASX.EQ.4) GO TO 12 8604 NI=N2C*N2C 8605 READ (11) (B(J,1),J=1,NI) 8606 REWIND 11 8607 CALL SOLVE (N2C,B,IP(JJ),XY(JJ),N2C) 8608 GO TO 13 860912 NBLSYS=NBLSYM 8610 NPSYS=NPSYM 8611 NLSYS=NLSYM 8612 ICASS=ICASE 8613 NBLSYM=NBBL 8614 NPSYM=NPBL 8615 NLSYM=NLBL 8616 ICASE=3 8617 REWIND 11 8618 REWIND 16 8619 CALL LTSOLV (B,N2C,IP(JJ),XY(JJ),N2C,1,11,16) 8620 REWIND 11 8621 REWIND 16 8622 NBLSYM=NBLSYS 8623 NPSYM=NPSYS 8624 NLSYM=NLSYS 8625 ICASE=ICASS 862613 NI=0 8627 NPB=NPBL 8628C COMPUTE INV(A)E1-(INV(A)B)I2 = I1 8629 DO 16 JJ=1,NBBL 8630 IF (JJ.EQ.NBBL) NPB=NLBL 8631 IF (ICASX.GT.1) READ (14) ((B(I,J),I=1,N1C),J=1,NPB) 8632 II=N1C+NI 8633 DO 15 I=1,N1C 8634 SUM=(0.,0.) 8635 DO 14 J=1,NPB 8636 JP=II+J 863714 SUM=SUM+B(I,J)*XY(JP) 863815 XY(I)=XY(I)-SUM 863916 NI=NI+NPBL 8640 IF (ICASX.GT.1) REWIND 14 8641 IF (N1.EQ.N.OR.M1.EQ.0) GO TO 20 8642C REORDER CURRENT ARRAY 8643 DO 17 I=N2,NPM 864417 Y(I)=XY(I) 8645 JJ=N1C+1 8646 J=N1 8647 DO 18 I=JJ,NPM 8648 J=J+1 864918 XY(J)=Y(I) 8650 DO 19 I=N2,N1C 8651 J=J+1 865219 XY(J)=Y(I) 865320 IF (NSCON.EQ.0) GO TO 22 8654 J=NEQS-1 8655 DO 21 I=1,NSCON 8656 J=J+1 8657 JJ=ISCON(I) 865821 XY(JJ)=XY(J) 865922 RETURN 8660 END 8661 SUBROUTINE SOLVE (N,A,IP,B,NDIM) 8662C *** 8663C DOUBLE PRECISION 6/4/85 8664C 8665 PARAMETER (MAXSEG=1500, MAXMAT=1500) 8666 IMPLICIT REAL*8(A-H,O-Z) 8667C *** 8668C 8669C SUBROUTINE TO SOLVE THE MATRIX EQUATION LU*X=B WHERE L IS A UNIT 8670C LOWER TRIANGULAR MATRIX AND U IS AN UPPER TRIANGULAR MATRIX BOTH 8671C OF WHICH ARE STORED IN A. THE RHS VECTOR B IS INPUT AND THE 8672C SOLUTION IS RETURNED THROUGH VECTOR B. 8673C 8674 COMPLEX*16 A,B,Y,SUM 8675 INTEGER PI 8676 COMMON /SCRATM/ Y(2*MAXSEG) 8677 DIMENSION A(NDIM,NDIM), IP(NDIM), B(NDIM) 8678C 8679C FORWARD SUBSTITUTION 8680C 8681 DO 3 I=1,N 8682 PI=IP(I) 8683 Y(I)=B(PI) 8684 B(PI)=B(I) 8685 IP1=I+1 8686 IF (IP1.GT.N) GO TO 2 8687 DO 1 J=IP1,N 8688 B(J)=B(J)-A(J,I)*Y(I) 86891 CONTINUE 86902 CONTINUE 86913 CONTINUE 8692C 8693C BACKWARD SUBSTITUTION 8694C 8695 DO 6 K=1,N 8696 I=N-K+1 8697 SUM=(0.,0.) 8698 IP1=I+1 8699 IF (IP1.GT.N) GO TO 5 8700 DO 4 J=IP1,N 8701 SUM=SUM+A(I,J)*B(J) 87024 CONTINUE 87035 CONTINUE 8704 B(I)=(Y(I)-SUM)/A(I,I) 87056 CONTINUE 8706 RETURN 8707 END 8708 SUBROUTINE SOLVES (A,IP,B,NEQ,NRH,NP,N,MP,M,IFL1,IFL2) 8709C *** 8710C DOUBLE PRECISION 6/4/85 8711C 8712 PARAMETER (MAXSEG=1500, MAXMAT=1500) 8713 IMPLICIT REAL*8(A-H,O-Z) 8714C *** 8715C 8716C SUBROUTINE SOLVES, FOR SYMMETRIC STRUCTURES, HANDLES THE 8717C TRANSFORMATION OF THE RIGHT HAND SIDE VECTOR AND SOLUTION OF THE 8718C MATRIX EQ. 8719C 8720 COMPLEX*16 A,B,Y,SUM,SSX 8721 COMMON /SMAT/ SSX(16,16) 8722 COMMON /SCRATM/ Y(2*MAXSEG) 8723 COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I 8724 1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL 8725 DIMENSION A(1), IP(1), B(NEQ,NRH) 8726 NPEQ=NP+2*MP 8727 NOP=NEQ/NPEQ 8728 FNOP=NOP 8729 FNORM=1./FNOP 8730 NROW=NEQ 8731 IF (ICASE.GT.3) NROW=NPEQ 8732 IF (NOP.EQ.1) GO TO 11 8733 DO 10 IC=1,NRH 8734 IF (N.EQ.0.OR.M.EQ.0) GO TO 6 8735 DO 1 I=1,NEQ 87361 Y(I)=B(I,IC) 8737 KK=2*MP 8738 IA=NP 8739 IB=N 8740 J=NP 8741 DO 5 K=1,NOP 8742 IF (K.EQ.1) GO TO 3 8743 DO 2 I=1,NP 8744 IA=IA+1 8745 J=J+1 87462 B(J,IC)=Y(IA) 8747 IF (K.EQ.NOP) GO TO 5 87483 DO 4 I=1,KK 8749 IB=IB+1 8750 J=J+1 87514 B(J,IC)=Y(IB) 87525 CONTINUE 8753C 8754C TRANSFORM MATRIX EQ. RHS VECTOR ACCORDING TO SYMMETRY MODES 8755C 87566 DO 10 I=1,NPEQ 8757 DO 7 K=1,NOP 8758 IA=I+(K-1)*NPEQ 87597 Y(K)=B(IA,IC) 8760 SUM=Y(1) 8761 DO 8 K=2,NOP 87628 SUM=SUM+Y(K) 8763 B(I,IC)=SUM*FNORM 8764 DO 10 K=2,NOP 8765 IA=I+(K-1)*NPEQ 8766 SUM=Y(1) 8767 DO 9 J=2,NOP 87689 SUM=SUM+Y(J)*DCONJG(SSX(K,J)) 876910 B(IA,IC)=SUM*FNORM 877011 IF (ICASE.LT.3) GO TO 12 8771 REWIND IFL1 8772 REWIND IFL2 8773C 8774C SOLVE EACH MODE EQUATION 8775C 877612 DO 16 KK=1,NOP 8777 IA=(KK-1)*NPEQ+1 8778 IB=IA 8779 IF (ICASE.NE.4) GO TO 13 8780 I=NPEQ*NPEQ 8781 READ (IFL1) (A(J),J=1,I) 8782 IB=1 878313 IF (ICASE.EQ.3.OR.ICASE.EQ.5) GO TO 15 8784 DO 14 IC=1,NRH 878514 CALL SOLVE (NPEQ,A(IB),IP(IA),B(IA,IC),NROW) 8786 GO TO 16 878715 CALL LTSOLV (A,NPEQ,IP(IA),B(IA,1),NEQ,NRH,IFL1,IFL2) 878816 CONTINUE 8789 IF (NOP.EQ.1) RETURN 8790C 8791C INVERSE TRANSFORM THE MODE SOLUTIONS 8792C 8793 DO 26 IC=1,NRH 8794 DO 20 I=1,NPEQ 8795 DO 17 K=1,NOP 8796 IA=I+(K-1)*NPEQ 879717 Y(K)=B(IA,IC) 8798 SUM=Y(1) 8799 DO 18 K=2,NOP 880018 SUM=SUM+Y(K) 8801 B(I,IC)=SUM 8802 DO 20 K=2,NOP 8803 IA=I+(K-1)*NPEQ 8804 SUM=Y(1) 8805 DO 19 J=2,NOP 880619 SUM=SUM+Y(J)*SSX(K,J) 880720 B(IA,IC)=SUM 8808 IF (N.EQ.0.OR.M.EQ.0) GO TO 26 8809 DO 21 I=1,NEQ 881021 Y(I)=B(I,IC) 8811 KK=2*MP 8812 IA=NP 8813 IB=N 8814 J=NP 8815 DO 25 K=1,NOP 8816 IF (K.EQ.1) GO TO 23 8817 DO 22 I=1,NP 8818 IA=IA+1 8819 J=J+1 882022 B(IA,IC)=Y(J) 8821 IF (K.EQ.NOP) GO TO 25 882223 DO 24 I=1,KK 8823 IB=IB+1 8824 J=J+1 882524 B(IB,IC)=Y(J) 882625 CONTINUE 882726 CONTINUE 8828 RETURN 8829 END 8830 SUBROUTINE TBF (I,ICAP) 8831C *** 8832C DOUBLE PRECISION 6/4/85 8833C 8834 PARAMETER (MAXSEG=1500, MAXMAT=1500) 8835 IMPLICIT REAL*8(A-H,O-Z) 8836C *** 8837C COMPUTE BASIS FUNCTION I 8838 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 8839 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 8840 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 8841 COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP 8842 1CON(10),NPCON 8843 DATA PI/3.141592654D+0/,JMAX/30/ 8844 JSNO=0 8845 PP=0. 8846 JCOX=ICON1(I) 8847 IF (JCOX.GT.10000) JCOX=I 8848 JEND=-1 8849 IEND=-1 8850 SIG=-1. 8851 IF (JCOX) 1,10,2 88521 JCOX=-JCOX 8853 GO TO 3 88542 SIG=-SIG 8855 JEND=-JEND 88563 JSNO=JSNO+1 8857 IF (JSNO.GE.JMAX) GO TO 28 8858 JCO(JSNO)=JCOX 8859 D=PI*SI(JCOX) 8860 SDH=SIN(D) 8861 CDH=COS(D) 8862 SD=2.*SDH*CDH 8863 IF (D.GT.0.015) GO TO 4 8864 OMC=4.*D*D 8865 OMC=((1.3888889D-3*OMC-4.1666666667D-2)*OMC+.5)*OMC 8866 GO TO 5 88674 OMC=1.-CDH*CDH+SDH*SDH 88685 AJ=1./(LOG(1./(PI*BI(JCOX)))-.577215664D+0) 8869 PP=PP-OMC/SD*AJ 8870 AX(JSNO)=AJ/SD*SIG 8871 BX(JSNO)=AJ/(2.*CDH) 8872 CX(JSNO)=-AJ/(2.*SDH)*SIG 8873 IF (JCOX.EQ.I) GO TO 8 8874 IF (JEND.EQ.1) GO TO 6 8875 JCOX=ICON1(JCOX) 8876 GO TO 7 88776 JCOX=ICON2(JCOX) 88787 IF (IABS(JCOX).EQ.I) GO TO 9 8879 IF (JCOX) 1,28,2 88808 BX(JSNO)=-BX(JSNO) 88819 IF (IEND.EQ.1) GO TO 11 888210 PM=-PP 8883 PP=0. 8884 NJUN1=JSNO 8885 JCOX=ICON2(I) 8886 IF (JCOX.GT.10000) JCOX=I 8887 JEND=1 8888 IEND=1 8889 SIG=-1. 8890 IF (JCOX) 1,11,2 889111 NJUN2=JSNO-NJUN1 8892 JSNOP=JSNO+1 8893 JCO(JSNOP)=I 8894 D=PI*SI(I) 8895 SDH=SIN(D) 8896 CDH=COS(D) 8897 SD=2.*SDH*CDH 8898 CD=CDH*CDH-SDH*SDH 8899 IF (D.GT.0.015) GO TO 12 8900 OMC=4.*D*D 8901 OMC=((1.3888889D-3*OMC-4.1666666667D-2)*OMC+.5)*OMC 8902 GO TO 13 890312 OMC=1.-CD 890413 AP=1./(LOG(1./(PI*BI(I)))-.577215664D+0) 8905 AJ=AP 8906 IF (NJUN1.EQ.0) GO TO 16 8907 IF (NJUN2.EQ.0) GO TO 20 8908 QP=SD*(PM*PP+AJ*AP)+CD*(PM*AP-PP*AJ) 8909 QM=(AP*OMC-PP*SD)/QP 8910 QP=-(AJ*OMC+PM*SD)/QP 8911 BX(JSNOP)=(AJ*QM+AP*QP)*SDH/SD 8912 CX(JSNOP)=(AJ*QM-AP*QP)*CDH/SD 8913 DO 14 IEND=1,NJUN1 8914 AX(IEND)=AX(IEND)*QM 8915 BX(IEND)=BX(IEND)*QM 891614 CX(IEND)=CX(IEND)*QM 8917 JEND=NJUN1+1 8918 DO 15 IEND=JEND,JSNO 8919 AX(IEND)=-AX(IEND)*QP 8920 BX(IEND)=BX(IEND)*QP 892115 CX(IEND)=-CX(IEND)*QP 8922 GO TO 27 892316 IF (NJUN2.EQ.0) GO TO 24 8924 IF (ICAP.NE.0) GO TO 17 8925 XXI=0. 8926 GO TO 18 892717 QP=PI*BI(I) 8928 XXI=QP*QP 8929 XXI=QP*(1.-.5*XXI)/(1.-XXI) 893018 QP=-(OMC+XXI*SD)/(SD*(AP+XXI*PP)+CD*(XXI*AP-PP)) 8931 D=CD-XXI*SD 8932 BX(JSNOP)=(SDH+AP*QP*(CDH-XXI*SDH))/D 8933 CX(JSNOP)=(CDH+AP*QP*(SDH+XXI*CDH))/D 8934 DO 19 IEND=1,NJUN2 8935 AX(IEND)=-AX(IEND)*QP 8936 BX(IEND)=BX(IEND)*QP 893719 CX(IEND)=-CX(IEND)*QP 8938 GO TO 27 893920 IF (ICAP.NE.0) GO TO 21 8940 XXI=0. 8941 GO TO 22 894221 QM=PI*BI(I) 8943 XXI=QM*QM 8944 XXI=QM*(1.-.5*XXI)/(1.-XXI) 894522 QM=(OMC+XXI*SD)/(SD*(AJ-XXI*PM)+CD*(PM+XXI*AJ)) 8946 D=CD-XXI*SD 8947 BX(JSNOP)=(AJ*QM*(CDH-XXI*SDH)-SDH)/D 8948 CX(JSNOP)=(CDH-AJ*QM*(SDH+XXI*CDH))/D 8949 DO 23 IEND=1,NJUN1 8950 AX(IEND)=AX(IEND)*QM 8951 BX(IEND)=BX(IEND)*QM 895223 CX(IEND)=CX(IEND)*QM 8953 GO TO 27 895424 BX(JSNOP)=0. 8955 IF (ICAP.NE.0) GO TO 25 8956 XXI=0. 8957 GO TO 26 895825 QP=PI*BI(I) 8959 XXI=QP*QP 8960 XXI=QP*(1.-.5*XXI)/(1.-XXI) 896126 CX(JSNOP)=1./(CDH-XXI*SDH) 896227 JSNO=JSNOP 8963 AX(JSNO)=-1. 8964 RETURN 896528 WRITE(3,29) I 8966 STOP 8967C 896829 FORMAT (43H TBF - SEGMENT CONNECTION ERROR FOR SEGMENT,I5) 8969 END 8970 SUBROUTINE TEST (F1R,F2R,TR,F1I,F2I,TI,DMIN) 8971C *** 8972C DOUBLE PRECISION 6/4/85 8973C 8974 IMPLICIT REAL*8(A-H,O-Z) 8975C *** 8976C 8977C TEST FOR CONVERGENCE IN NUMERICAL INTEGRATION 8978C 8979 DEN=ABS(F2R) 8980 TR=ABS(F2I) 8981 IF (DEN.LT.TR) DEN=TR 8982 IF (DEN.LT.DMIN) DEN=DMIN 8983 IF (DEN.LT.1.D-37) GO TO 1 8984 TR=ABS((F1R-F2R)/DEN) 8985 TI=ABS((F1I-F2I)/DEN) 8986 RETURN 89871 TR=0. 8988 TI=0. 8989 RETURN 8990 END 8991 SUBROUTINE TRIO (J) 8992C *** 8993C DOUBLE PRECISION 6/4/85 8994C 8995 PARAMETER (MAXSEG=1500, MAXMAT=1500) 8996 IMPLICIT REAL*8(A-H,O-Z) 8997C *** 8998C COMPUTE THE COMPONENTS OF ALL BASIS FUNCTIONS ON SEGMENT J 8999 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 9000 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 9001 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 9002 COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,IP 9003 1CON(10),NPCON 9004 DATA JMAX/30/ 9005 JSNO=0 9006 JCOX=ICON1(J) 9007 IF (JCOX.GT.10000) GO TO 7 9008 JEND=-1 9009 IEND=-1 9010 IF (JCOX) 1,7,2 90111 JCOX=-JCOX 9012 GO TO 3 90132 JEND=-JEND 90143 IF (JCOX.EQ.J) GO TO 6 9015 JSNO=JSNO+1 9016 IF (JSNO.GE.JMAX) GO TO 9 9017 CALL SBF (JCOX,J,AX(JSNO),BX(JSNO),CX(JSNO)) 9018 JCO(JSNO)=JCOX 9019 IF (JEND.EQ.1) GO TO 4 9020 JCOX=ICON1(JCOX) 9021 GO TO 5 90224 JCOX=ICON2(JCOX) 90235 IF (JCOX) 1,9,2 90246 IF (IEND.EQ.1) GO TO 8 90257 JCOX=ICON2(J) 9026 IF (JCOX.GT.10000) GO TO 8 9027 JEND=1 9028 IEND=1 9029 IF (JCOX) 1,8,2 90308 JSNO=JSNO+1 9031 CALL SBF (J,J,AX(JSNO),BX(JSNO),CX(JSNO)) 9032 JCO(JSNO)=J 9033 RETURN 90349 WRITE(3,10) J 9035 STOP 9036C 903710 FORMAT (44H TRIO - SEGMENT CONNENTION ERROR FOR SEGMENT,I5) 9038 END 9039 SUBROUTINE UNERE (XOB,YOB,ZOB) 9040C *** 9041C DOUBLE PRECISION 6/4/85 9042C 9043 IMPLICIT REAL*8(A-H,O-Z) 9044C *** 9045C CALCULATES THE ELECTRIC FIELD DUE TO UNIT CURRENT IN THE T1 AND T2 9046C DIRECTIONS ON A PATCH 9047 COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,ZRATI,ZRATI2,T1 9048 1,ER,Q1,Q2,RRV,RRH,EDP,FRATI 9049 COMMON /DATAJ/ S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS, 9050 &EZS,EXC,EYC,EZC,RKH,IND1,INDD1,IND2,INDD2,IEXK,IPGND 9051 COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL, 9052 &KSYMP,IFAR,IPERF 9053 EQUIVALENCE (T1XJ,CABJ), (T1YJ,SABJ), (T1ZJ,SALPJ), (T2XJ,B), (T2Y 9054 1J,IND1), (T2ZJ,IND2) 9055 DATA TPI,CONST/6.283185308D+0,4.771341188D+0/ 9056C CONST=ETA/(8.*PI**2) 9057 ZR=ZJ 9058 T1ZR=T1ZJ 9059 T2ZR=T2ZJ 9060 IF (IPGND.NE.2) GO TO 1 9061 ZR=-ZR 9062 T1ZR=-T1ZR 9063 T2ZR=-T2ZR 90641 RX=XOB-XJ 9065 RY=YOB-YJ 9066 RZ=ZOB-ZR 9067 R2=RX*RX+RY*RY+RZ*RZ 9068 IF (R2.GT.1.D-20) GO TO 2 9069 EXK=(0.,0.) 9070 EYK=(0.,0.) 9071 EZK=(0.,0.) 9072 EXS=(0.,0.) 9073 EYS=(0.,0.) 9074 EZS=(0.,0.) 9075 RETURN 90762 R=SQRT(R2) 9077 TT1=-TPI*R 9078 TT2=TT1*TT1 9079 RT=R2*R 9080 ER=DCMPLX(SIN(TT1),-COS(TT1))*(CONST*S) 9081 Q1=DCMPLX(TT2-1.,TT1)*ER/RT 9082 Q2=DCMPLX(3.-TT2,-3.*TT1)*ER/(RT*R2) 9083 ER=Q2*(T1XJ*RX+T1YJ*RY+T1ZR*RZ) 9084 EXK=Q1*T1XJ+ER*RX 9085 EYK=Q1*T1YJ+ER*RY 9086 EZK=Q1*T1ZR+ER*RZ 9087 ER=Q2*(T2XJ*RX+T2YJ*RY+T2ZR*RZ) 9088 EXS=Q1*T2XJ+ER*RX 9089 EYS=Q1*T2YJ+ER*RY 9090 EZS=Q1*T2ZR+ER*RZ 9091 IF (IPGND.EQ.1) GO TO 6 9092 IF (IPERF.NE.1) GO TO 3 9093 EXK=-EXK 9094 EYK=-EYK 9095 EZK=-EZK 9096 EXS=-EXS 9097 EYS=-EYS 9098 EZS=-EZS 9099 GO TO 6 91003 XYMAG=SQRT(RX*RX+RY*RY) 9101 IF (XYMAG.GT.1.D-6) GO TO 4 9102 PX=0. 9103 PY=0. 9104 CTH=1. 9105 RRV=(1.,0.) 9106 GO TO 5 91074 PX=-RY/XYMAG 9108 PY=RX/XYMAG 9109 CTH=RZ/SQRT(XYMAG*XYMAG+RZ*RZ) 9110 RRV=SQRT(1.-ZRATI*ZRATI*(1.-CTH*CTH)) 91115 RRH=ZRATI*CTH 9112 RRH=(RRH-RRV)/(RRH+RRV) 9113 RRV=ZRATI*RRV 9114 RRV=-(CTH-RRV)/(CTH+RRV) 9115 EDP=(EXK*PX+EYK*PY)*(RRH-RRV) 9116 EXK=EXK*RRV+EDP*PX 9117 EYK=EYK*RRV+EDP*PY 9118 EZK=EZK*RRV 9119 EDP=(EXS*PX+EYS*PY)*(RRH-RRV) 9120 EXS=EXS*RRV+EDP*PX 9121 EYS=EYS*RRV+EDP*PY 9122 EZS=EZS*RRV 91236 RETURN 9124 END 9125 SUBROUTINE WIRE (XW1,YW1,ZW1,XW2,YW2,ZW2,RAD,RDEL,RRAD,NS,ITG) 9126C *** 9127C DOUBLE PRECISION 6/4/85 9128C 9129 PARAMETER (MAXSEG=1500, MAXMAT=1500) 9130 IMPLICIT REAL*8(A-H,O-Z) 9131C *** 9132C 9133C SUBROUTINE WIRE GENERATES SEGMENT GEOMETRY DATA FOR A STRAIGHT 9134C WIRE OF NS SEGMENTS. 9135C 9136 COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG), 9137 &ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG), 9138 &ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM 9139 DIMENSION X2(1), Y2(1), Z2(1) 9140 EQUIVALENCE (X2(1),SI(1)), (Y2(1),ALP(1)), (Z2(1),BET(1)) 9141 IST=N+1 9142 N=N+NS 9143 NP=N 9144 MP=M 9145 IPSYM=0 9146 IF (NS.LT.1) RETURN 9147 XD=XW2-XW1 9148 YD=YW2-YW1 9149 ZD=ZW2-ZW1 9150 IF (ABS(RDEL-1.).LT.1.D-6) GO TO 1 9151 DELZ=SQRT(XD*XD+YD*YD+ZD*ZD) 9152 XD=XD/DELZ 9153 YD=YD/DELZ 9154 ZD=ZD/DELZ 9155 DELZ=DELZ*(1.-RDEL)/(1.-RDEL**NS) 9156 RD=RDEL 9157 GO TO 2 91581 FNS=NS 9159 XD=XD/FNS 9160 YD=YD/FNS 9161 ZD=ZD/FNS 9162 DELZ=1. 9163 RD=1. 91642 RADZ=RAD 9165 XS1=XW1 9166 YS1=YW1 9167 ZS1=ZW1 9168 DO 3 I=IST,N 9169 ITAG(I)=ITG 9170 XS2=XS1+XD*DELZ 9171 YS2=YS1+YD*DELZ 9172 ZS2=ZS1+ZD*DELZ 9173 X(I)=XS1 9174 Y(I)=YS1 9175 Z(I)=ZS1 9176 X2(I)=XS2 9177 Y2(I)=YS2 9178 Z2(I)=ZS2 9179 BI(I)=RADZ 9180 DELZ=DELZ*RD 9181 RADZ=RADZ*RRAD 9182 XS1=XS2 9183 YS1=YS2 91843 ZS1=ZS2 9185 X2(N)=XW2 9186 Y2(N)=YW2 9187 Z2(N)=ZW2 9188 RETURN 9189 END 9190 COMPLEX*16 FUNCTION ZINT(SIGL,ROLAM) 9191C *** 9192C DOUBLE PRECISION 6/4/85 9193C 9194 IMPLICIT REAL*8(A-H,O-Z) 9195C *** 9196C 9197C ZINT COMPUTES THE INTERNAL IMPEDANCE OF A CIRCULAR WIRE 9198C 9199C 9200 COMPLEX*16 TH,PH,F,G,FJ,CN,BR1,BR2 9201 COMPLEX*16 CC1,CC2,CC3,CC4,CC5,CC6,CC7,CC8,CC9,CC10,CC11,CC12 9202 1,CC13,CC14 9203 DIMENSION FJX(2), CNX(2), CCN(28) 9204 EQUIVALENCE (FJ,FJX), (CN,CNX), (CC1,CCN(1)), (CC2,CCN(3)), (CC3,C 9205 1CN(5)), (CC4,CCN(7)), (CC5,CCN(9)), (CC6,CCN(11)), (CC7,CCN(13)), 9206 2(CC8,CCN(15)), (CC9,CCN(17)), (CC10,CCN(19)), (CC11,CCN(21)), (CC1 9207 32,CCN(23)), (CC13,CCN(25)), (CC14,CCN(27)) 9208 DATA PI,POT,TP,TPCMU/3.1415926D+0,1.5707963D+0,6.2831853D+0, 9209 12.368705D+3/ 9210 DATA CMOTP/60.00/,FJX/0.,1./,CNX/.70710678D+0,.70710678D+0/ 9211 DATA CCN/6.D-7,1.9D-6,-3.4D-6,5.1D-6,-2.52D-5,0.,-9.06D-5,-9.01D-5 9212 1,0.,-9.765D-4,.0110486D+0,-.0110485D+0,0.,-.3926991D+0,1.6D-6, 9213 2-3.2D-6,1.17D-5,-2.4D-6,3.46D-5,3.38D-5,5.D-7,2.452D-4,-1.3813D-3 9214 3,1.3811D-3,-6.25001D-2,-1.D-7,.7071068D+0,.7071068D+0/ 9215 TH(D)=(((((CC1*D+CC2)*D+CC3)*D+CC4)*D+CC5)*D+CC6)*D+CC7 9216 PH(D)=(((((CC8*D+CC9)*D+CC10)*D+CC11)*D+CC12)*D+CC13)*D+CC14 9217 F(D)=SQRT(POT/D)*EXP(-CN*D+TH(-8./X)) 9218 G(D)=EXP(CN*D+TH(8./X))/SQRT(TP*D) 9219 X=SQRT(TPCMU*SIGL)*ROLAM 9220 IF (X.GT.110.) GO TO 2 9221 IF (X.GT.8.) GO TO 1 9222 Y=X/8. 9223 Y=Y*Y 9224 S=Y*Y 9225 BER=((((((-9.01D-6*S+1.22552D-3)*S-.08349609D+0)*S+2.6419140D+0) 9226 1*S-32.363456D+0)*S+113.77778D+0)*S-64.)*S+1. 9227 BEI=((((((1.1346D-4*S-.01103667D+0)*S+.52185615D+0)*S- 9228 110.567658D+0)*S+72.817777D+0)*S-113.77778D+0)*S+16.)*Y 9229 BR1=DCMPLX(BER,BEI) 9230 BER=(((((((-3.94D-6*S+4.5957D-4)*S-.02609253D+0)*S+.66047849D+0) 9231 1*S-6.0681481D+0)*S+14.222222D+0)*S-4.)*Y)*X 9232 BEI=((((((4.609D-5*S-3.79386D-3)*S+.14677204D+0)*S-2.3116751D+0) 9233 1*S+11.377778D+0)*S-10.666667D+0)*S+.5)*X 9234 BR2=DCMPLX(BER,BEI) 9235 BR1=BR1/BR2 9236 GO TO 3 92371 BR2=FJ*F(X)/PI 9238 BR1=G(X)+BR2 9239 BR2=G(X)*PH(8./X)-BR2*PH(-8./X) 9240 BR1=BR1/BR2 9241 GO TO 3 92422 BR1=DCMPLX(.70710678D+0,-.70710678D+0) 92433 ZINT=FJ*SQRT(CMOTP/SIGL)*BR1/ROLAM 9244 RETURN 9245 END 9246 logical*4 function GetPut(what,where,message,file,volume,nt,types) 9247C 9248C implicit none 9249C 9250C integer NEWHANDLE 9251C parameter (NEWHANDLE = Z'122000A8') 9252C integer HLOCK 9253C parameter (HLOCK = Z'02980008') 9254C integer HUNLOCK 9255C parameter (HUNLOCK = Z'02A80008') 9256C integer NEWDIALOG 9257C parameter (NEWDIALOG = Z'97D20002') 9258C integer DISPOSHANDLE 9259C parameter (DISPOSHANDLE = Z'02380008') 9260C integer SFPUTFILE 9261C parameter (SFPUTFILE = Z'9EA16CB1') 9262C integer SFGETFILE 9263C parameter (SFGETFILE = Z'9EA20003') 9264C integer PTR 9265C parameter (PTR = Z'C0000000') 9266C integer DISPOSEDIALOG 9267C parameter (DISPOSEDIALOG = Z'98310000') 9268C integer PBSETVOL 9269C parameter (PBSETVOL = Z'01580010') 9270C 9271C integer*4 what ! 0 SFPUTFILE; 1 SFGETFILE 9272C integer*2 where(2) ! location of box upper-left corner (y,x) 9273C character*(*) message ! string to go over dialog box 9274C character*(*) file ! file name 9275C integer*4 volume ! volume number 9276C integer*4 nt ! number of filter types 9277C character*(*) types ! filter types 9278C 9279C integer*4 toolbx ! toolbx interface 9280C 9281C integer*4 dptr ! dialog pointer 9282C character*64 fname 9283C logical*1 good ! result flag 9284C integer*4 i 9285C integer*2 iovrefnum 9286C integer*4 lhdl ! handle of item list 9287C integer*4 lptr ! pointer to item list 9288C integer*4 nc ! number of characters in file name 9289C integer*2 posd(2) ! location of standard dialog 9290C integer*2 rect(4) ! rectangle 9291C integer*2 vrefnum 9292C integer*1 params(108) ! partial PBGETVOL parameter block 9293C equivalence (params(23),iovrefnum) 9294C integer*1 reply(76) ! reply record 9295C equivalence (reply(1),good) 9296C equivalence (reply(7),vrefnum) 9297C equivalence (reply(11),fname) 9298C 9299 GetPut = .false. 9300C volume = 0 9301C good = .true. 9302C if (what .eq. 0) then 9303C lhdl = 0 9304C lhdl = toolbx(NEWHANDLE,72) 9305C if (lhdl .eq. 0) return 9306C call toolbx(HLOCK,lhdl) 9307C lptr = LONG(lhdl) 9308C WORD(lptr) = 1 9309C LONG(lptr + 2) = 0 9310C WORD(lptr + 6) = 0 9311C WORD(lptr + 8) = 0 9312C WORD(lptr + 10) = 32 9313C WORD(lptr + 12) = 32 9314C BYTE(lptr + 14) = 160 9315C BYTE(lptr + 15) = 2 9316C WORD(lptr + 16) = 1 9317C LONG(lptr + 18) = 0 9318C WORD(lptr + 22) = 8 9319C WORD(lptr + 24) = 40 9320C WORD(lptr + 26) = 24 9321C WORD(lptr + 28) = 304 9322C BYTE(lptr + 30) = 136 9323C BYTE(lptr + 31) = 40 9324C do (i = 1, 40) 9325C BYTE(lptr + 31 + i) = ICHAR(message(i:i)) 9326C enddo 9327C call toolbx(HUNLOCK,lhdl) 9328C rect(1) = where(1) 9329C rect(2) = where(2) 9330C rect(3) = rect(1) + 32 9331C rect(4) = rect(2) + 304 9332C elseif (what .eq. 1) then 9333C lhdl = 0 9334C lhdl = toolbx(NEWHANDLE,80) 9335C if (lhdl .eq. 0) return 9336C call toolbx(HLOCK,lhdl) 9337C lptr = LONG(lhdl) 9338C WORD(lptr) = 1 9339C LONG(lptr + 2) = 0 9340C WORD(lptr + 6) = 0 9341C WORD(lptr + 8) = 0 9342C WORD(lptr + 10) = 32 9343C WORD(lptr + 12) = 32 9344C BYTE(lptr + 14) = 160 9345C BYTE(lptr + 15) = 2 9346C WORD(lptr + 16) = 1 9347C LONG(lptr + 18) = 0 9348C WORD(lptr + 22) = 8 9349C WORD(lptr + 24) = 40 9350C WORD(lptr + 26) = 24 9351C WORD(lptr + 28) = 348 9352C BYTE(lptr + 30) = 136 9353C BYTE(lptr + 31) = 48 9354C do (i = 1, 48) 9355C BYTE(lptr + 31 + i) = ICHAR(message(i:i)) 9356C enddo 9357C call toolbx(HUNLOCK,lhdl) 9358C rect(1) = where(1) 9359C rect(2) = where(2) 9360C rect(3) = rect(1) + 32 9361C rect(4) = rect(2) + 348 9362C else 9363C return 9364C endif 9365C dptr = 0 9366C dptr = toolbx(NEWDIALOG,0,rect,0,.true.,1,-1,.false.,0,lhdl) 9367C if (dptr .eq. 0) then 9368C call toolbx(DISPOSHANDLE,lhdl) 9369C return 9370C endif 9371C posd(1) = where(1) + 50 9372C posd(2) = where(2) 9373C if (what .eq. 0) then 9374C call toolbx(SFPUTFILE,posd,0,0,0,reply,1) 9375C else 9376C call toolbx(SFGETFILE,posd,0,0,nt,toolbx(PTR,types),0,reply,2) 9377C endif 9378C call toolbx(DISPOSEDIALOG,dptr) ! Dispose of Header dialog 9379C if (good .eq. .false.) return 9380C nc = ICHAR(fname(1:1)) 9381C file = fname(2:nc + 1) 9382C do (i = 1, 108) 9383C params(i) = 0 9384C enddo 9385C iovrefnum = vrefnum 9386C if (toolbx(PBSETVOL,toolbx(PTR,params)) .eq. 0) then 9387C GetPut = .true. 9388C volume = vrefnum 9389C endif 9390C 9391 return 9392 end 9393C Last change: PGM 8 Nov 2000 1:04 pm 9394C PROGRAM SOMNEC(INPUT,OUTPUT,TAPE21) 9395C 9396C PROGRAM TO GENERATE NEC INTERPOLATION GRIDS FOR FIELDS DUE TO 9397C GROUND. FIELD COMPONENTS ARE COMPUTED BY NUMERICAL EVALUATION 9398C OF MODIFIED SOMMERFELD INTEGRALS. 9399C 9400C SOMNEC2D IS A DOUBLE PRECISION VERSION OF SOMNEC FOR USE WITH 9401C NEC2D. AN ALTERNATE VERSION (SOMNEC2SD) IS ALSO PROVIDED IN WHICH 9402C COMPUTATION IS IN SINGLE PRECISION BUT THE OUTPUT FILE IS WRITTEN 9403C IN DOUBLE PRECISION FOR USE WITH NEC2D. SOMNEC2SD RUNS ABOUT TWIC 9404C AS FAST AS THE FULL DOUBLE PRECISION SOMNEC2D. THE DIFFERENCE 9405C BETWEEN NEC2D RESULTS USING A FOR021 FILE FROM THIS CODE RATHER 9406C THAN FROM SOMNEC2SD WAS INSIGNFICANT IN THE CASES TESTED. 9407C 9408C Changes made by J Bergervoet, 31-5-95: 9409C Parameter 0. --> 0.D0 in calling of routine TEST 9410C Status of output files set to 'UNKNOWN' 9411C*** 9412 SUBROUTINE SOMNEC(EPR, SIG, FMHZ) 9413 IMPLICIT REAL*8(A-H,O-Z) 9414C*** 9415 COMPLEX*16 CK1,CK1SQ,ERV,EZV,ERH,EPH,CKSM,CT1,CT2,CT3,CL1,CL2,CON, 9416 1AR1,AR2,AR3,EPSCF 9417 COMMON /EVLCOM/ CKSM,CT1,CT2,CT3,CK1,CK1SQ,CK2,CK2SQ,TKMAG,TSMAG,C 9418 1K1R,ZPH,RHO,JH 9419 COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),DY 9420 1A(3),XSA(3),YSA(3),NXA(3),NYA(3) 9421 DATA NXA/11,17,9/,NYA/10,5,8/,XSA/0.,.2,.2/,YSA/0.,0.,.3490658504/ 9422 DATA DXA/.02,.05,.1/,DYA/.1745329252,.0872664626,.1745329252/ 9423 CHARACTER*3 LCOMP(4) 9424 DATA LCOMP/'ERV','EZV','ERH','EPH'/ 9425C*** 9426 IF (SIG.LT.0.) GO TO 1 9427 WLAM=299.8/FMHZ 9428 EPSCF=DCMPLX(EPR,-SIG*WLAM*59.96) 9429 GO TO 2 94301 EPSCF=DCMPLX(EPR,SIG) 94312 CALL SECONDS (TST) 9432 CK2=6.283185308 9433 CK2SQ=CK2*CK2 9434C 9435C SOMMERFELD INTEGRAL EVALUATION USES EXP(-JWT), NEC USES EXP(+JWT), 9436C HENCE NEED CONJG(EPSCF). CONJUGATE OF FIELDS OCCURS IN SUBROUTINE 9437C EVLUA. 9438C 9439 CK1SQ=CK2SQ*DCONJG(EPSCF) 9440 CK1=SQRT(CK1SQ) 9441 CK1R=DREAL(CK1) 9442 TKMAG=100.*ABS(CK1) 9443 TSMAG=100.*CK1*DCONJG(CK1) 9444 CKSM=CK2SQ/(CK1SQ+CK2SQ) 9445 CT1=.5*(CK1SQ-CK2SQ) 9446 ERV=CK1SQ*CK1SQ 9447 EZV=CK2SQ*CK2SQ 9448 CT2=.125*(ERV-EZV) 9449 ERV=ERV*CK1SQ 9450 EZV=EZV*CK2SQ 9451 CT3=.0625*(ERV-EZV) 9452C 9453C LOOP OVER 3 GRID REGIONS 9454C 9455 DO 6 K=1,3 9456 NR=NXA(K) 9457 NTH=NYA(K) 9458 DR=DXA(K) 9459 DTH=DYA(K) 9460 R=XSA(K)-DR 9461 IRS=1 9462 IF (K.EQ.1) R=XSA(K) 9463 IF (K.EQ.1) IRS=2 9464C 9465C LOOP OVER R. (R=SQRT(RHO**2 + (Z+H)**2)) 9466C 9467 DO 6 IR=IRS,NR 9468 R=R+DR 9469 THET=YSA(K)-DTH 9470C 9471C LOOP OVER THETA. (THETA=ATAN((Z+H)/RHO)) 9472C 9473 DO 6 ITH=1,NTH 9474 THET=THET+DTH 9475 RHO=R*COS(THET) 9476 ZPH=R*SIN(THET) 9477 IF (RHO.LT.1.E-7) RHO=1.E-8 9478 IF (ZPH.LT.1.E-7) ZPH=0. 9479 CALL EVLUA (ERV,EZV,ERH,EPH) 9480 RK=CK2*R 9481 CON=-(0.,4.77147)*R/DCMPLX(COS(RK),-SIN(RK)) 9482 GO TO (3,4,5), K 94833 AR1(IR,ITH,1)=ERV*CON 9484 AR1(IR,ITH,2)=EZV*CON 9485 AR1(IR,ITH,3)=ERH*CON 9486 AR1(IR,ITH,4)=EPH*CON 9487 GO TO 6 94884 AR2(IR,ITH,1)=ERV*CON 9489 AR2(IR,ITH,2)=EZV*CON 9490 AR2(IR,ITH,3)=ERH*CON 9491 AR2(IR,ITH,4)=EPH*CON 9492 GO TO 6 94935 AR3(IR,ITH,1)=ERV*CON 9494 AR3(IR,ITH,2)=EZV*CON 9495 AR3(IR,ITH,3)=ERH*CON 9496 AR3(IR,ITH,4)=EPH*CON 94976 CONTINUE 9498C 9499C FILL GRID 1 FOR R EQUAL TO ZERO. 9500C 9501 CL2=-(0.,188.370)*(EPSCF-1.)/(EPSCF+1.) 9502 CL1=CL2/(EPSCF+1.) 9503 EZV=EPSCF*CL1 9504 THET=-DTH 9505 NTH=NYA(1) 9506 DO 9 ITH=1,NTH 9507 THET=THET+DTH 9508 IF (ITH.EQ.NTH) GO TO 7 9509 TFAC2=COS(THET) 9510 TFAC1=(1.-SIN(THET))/TFAC2 9511 TFAC2=TFAC1/TFAC2 9512 ERV=EPSCF*CL1*TFAC1 9513 ERH=CL1*(TFAC2-1.)+CL2 9514 EPH=CL1*TFAC2-CL2 9515 GO TO 8 95167 ERV=0. 9517 ERH=CL2-.5*CL1 9518 EPH=-ERH 95198 AR1(1,ITH,1)=ERV 9520 AR1(1,ITH,2)=EZV 9521 AR1(1,ITH,3)=ERH 95229 AR1(1,ITH,4)=EPH 9523 CALL SECONDS (TIM) 952414 TIM=TIM-TST 9525 WRITE(3,16) TIM 952616 FORMAT (40X,12HSOMNEC TIME=,E12.3,8H SECONDS) 9527 RETURN 9528C 9529 END 9530 SUBROUTINE BESSEL (Z,J0,J0P) 9531C 9532C BESSEL EVALUATES THE ZERO-ORDER BESSEL FUNCTION AND ITS DERIVATIVE 9533C FOR COMPLEX ARGUMENT Z. 9534C 9535 IMPLICIT REAL*8(A-H,O-Z) 9536 SAVE 9537 COMPLEX*16 J0,J0P,P0Z,P1Z,Q0Z,Q1Z,Z,ZI,ZI2,ZK,FJ,CZ,SZ,J0X,J0PX 9538 DIMENSION M(101), A1(25), A2(25), FJX(2) 9539 EQUIVALENCE (FJ,FJX) 9540 DATA PI,C3,P10,P20,Q10,Q20/3.141592654,.7978845608,.0703125,.11215 9541 120996,.125,.0732421875/ 9542 DATA P11,P21,Q11,Q21/.1171875,.1441955566,.375,.1025390625/ 9543 DATA POF,INIT/.7853981635,0/,FJX/0.,1./ 9544 IF (INIT.EQ.0) GO TO 5 95451 ZMS=Z*DCONJG(Z) 9546 IF (ZMS.GT.1.E-12) GO TO 2 9547 J0=(1.,0.) 9548 J0P=-.5*Z 9549 RETURN 95502 IB=0 9551 IF (ZMS.GT.37.21) GO TO 4 9552 IF (ZMS.GT.36.) IB=1 9553C SERIES EXPANSION 9554 IZ=1.+ZMS 9555 MIZ=M(IZ) 9556 J0=(1.,0.) 9557 J0P=J0 9558 ZK=J0 9559 ZI=Z*Z 9560 DO 3 K=1,MIZ 9561 ZK=ZK*A1(K)*ZI 9562 J0=J0+ZK 95633 J0P=J0P+A2(K)*ZK 9564 J0P=-.5*Z*J0P 9565 IF (IB.EQ.0) RETURN 9566 J0X=J0 9567 J0PX=J0P 9568C ASYMPTOTIC EXPANSION 95694 ZI=1./Z 9570 ZI2=ZI*ZI 9571 P0Z=1.+(P20*ZI2-P10)*ZI2 9572 P1Z=1.+(P11-P21*ZI2)*ZI2 9573 Q0Z=(Q20*ZI2-Q10)*ZI 9574 Q1Z=(Q11-Q21*ZI2)*ZI 9575 ZK=EXP(FJ*(Z-POF)) 9576 ZI2=1./ZK 9577 CZ=.5*(ZK+ZI2) 9578 SZ=FJ*.5*(ZI2-ZK) 9579 ZK=C3*SQRT(ZI) 9580 J0=ZK*(P0Z*CZ-Q0Z*SZ) 9581 J0P=-ZK*(P1Z*SZ+Q1Z*CZ) 9582 IF (IB.EQ.0) RETURN 9583 ZMS=COS((SQRT(ZMS)-6.)*31.41592654) 9584 J0=.5*(J0X*(1.+ZMS)+J0*(1.-ZMS)) 9585 J0P=.5*(J0PX*(1.+ZMS)+J0P*(1.-ZMS)) 9586 RETURN 9587C INITIALIZATION OF CONSTANTS 95885 DO 6 K=1,25 9589 A1(K)=-.25D0/(K*K) 95906 A2(K)=1.D0/(K+1.D0) 9591 DO 8 I=1,101 9592 TEST=1.D0 9593 DO 7 K=1,24 9594 INIT=K 9595 TEST=-TEST*I*A1(K) 9596 IF (TEST.LT.1.D-6) GO TO 8 95977 CONTINUE 95988 M(I)=INIT 9599 GO TO 1 9600 END 9601 SUBROUTINE EVLUA (ERV,EZV,ERH,EPH) 9602C 9603C EVALUA CONTROLS THE INTEGRATION CONTOUR IN THE COMPLEX LAMBDA 9604C PLANE FOR EVALUATION OF THE SOMMERFELD INTEGRALS. 9605C 9606 IMPLICIT REAL*8(A-H,O-Z) 9607 SAVE 9608 COMPLEX*16 ERV,EZV,ERH,EPH,A,B,CK1,CK1SQ,BK,SUM,DELTA,ANS,DELTA2, 9609 1CP1,CP2,CP3,CKSM,CT1,CT2,CT3 9610 COMMON /CNTOUR/ A,B 9611 COMMON /EVLCOM/ CKSM,CT1,CT2,CT3,CK1,CK1SQ,CK2,CK2SQ,TKMAG,TSMAG,C 9612 1K1R,ZPH,RHO,JH 9613 DIMENSION SUM(6), ANS(6) 9614 DATA PTP/.6283185308/ 9615 DEL=ZPH 9616 IF (RHO.GT.DEL) DEL=RHO 9617 IF (ZPH.LT.2.*RHO) GO TO 4 9618C 9619C BESSEL FUNCTION FORM OF SOMMERFELD INTEGRALS 9620C 9621 JH=0 9622 A=(0.,0.) 9623 DEL=1./DEL 9624 IF (DEL.LE.TKMAG) GO TO 2 9625 B=DCMPLX(.1*TKMAG,-.1*TKMAG) 9626 CALL ROM1 (6,SUM,2) 9627 A=B 9628 B=DCMPLX(DEL,-DEL) 9629 CALL ROM1 (6,ANS,2) 9630 DO 1 I=1,6 96311 SUM(I)=SUM(I)+ANS(I) 9632 GO TO 3 96332 B=DCMPLX(DEL,-DEL) 9634 CALL ROM1 (6,SUM,2) 96353 DELTA=PTP*DEL 9636 CALL GSHANK (B,DELTA,ANS,6,SUM,0,B,B) 9637 GO TO 10 9638C 9639C HANKEL FUNCTION FORM OF SOMMERFELD INTEGRALS 9640C 96414 JH=1 9642 CP1=DCMPLX(0.D0,.4*CK2) 9643 CP2=DCMPLX(.6*CK2,-.2*CK2) 9644 CP3=DCMPLX(1.02*CK2,-.2*CK2) 9645 A=CP1 9646 B=CP2 9647 CALL ROM1 (6,SUM,2) 9648 A=CP2 9649 B=CP3 9650 CALL ROM1 (6,ANS,2) 9651 DO 5 I=1,6 96525 SUM(I)=-(SUM(I)+ANS(I)) 9653C PATH FROM IMAGINARY AXIS TO -INFINITY 9654 SLOPE=1000. 9655 IF (ZPH.GT..001*RHO) SLOPE=RHO/ZPH 9656 DEL=PTP/DEL 9657 DELTA=DCMPLX(-1.D0,SLOPE)*DEL/SQRT(1.+SLOPE*SLOPE) 9658 DELTA2=-DCONJG(DELTA) 9659 CALL GSHANK (CP1,DELTA,ANS,6,SUM,0,BK,BK) 9660 RMIS=RHO*(DREAL(CK1)-CK2) 9661 IF (RMIS.LT.2.*CK2) GO TO 8 9662 IF (RHO.LT.1.E-10) GO TO 8 9663 IF (ZPH.LT.1.E-10) GO TO 6 9664 BK=DCMPLX(-ZPH,RHO)*(CK1-CP3) 9665 RMIS=-DREAL(BK)/ABS(DIMAG(BK)) 9666 IF(RMIS.GT.4.*RHO/ZPH)GO TO 8 9667C INTEGRATE UP BETWEEN BRANCH CUTS, THEN TO + INFINITY 96686 CP1=CK1-(.1,.2) 9669 CP2=CP1+.2 9670 BK=DCMPLX(0.D0,DEL) 9671 CALL GSHANK (CP1,BK,SUM,6,ANS,0,BK,BK) 9672 A=CP1 9673 B=CP2 9674 CALL ROM1 (6,ANS,1) 9675 DO 7 I=1,6 96767 ANS(I)=ANS(I)-SUM(I) 9677 CALL GSHANK (CP3,BK,SUM,6,ANS,0,BK,BK) 9678 CALL GSHANK (CP2,DELTA2,ANS,6,SUM,0,BK,BK) 9679 GO TO 10 9680C INTEGRATE BELOW BRANCH POINTS, THEN TO + INFINITY 96818 DO 9 I=1,6 96829 SUM(I)=-ANS(I) 9683 RMIS=DREAL(CK1)*1.01 9684 IF (CK2+1..GT.RMIS) RMIS=CK2+1. 9685 BK=DCMPLX(RMIS,.99*DIMAG(CK1)) 9686 DELTA=BK-CP3 9687 DELTA=DELTA*DEL/ABS(DELTA) 9688 CALL GSHANK (CP3,DELTA,ANS,6,SUM,1,BK,DELTA2) 968910 ANS(6)=ANS(6)*CK1 9690C CONJUGATE SINCE NEC USES EXP(+JWT) 9691 ERV=DCONJG(CK1SQ*ANS(3)) 9692 EZV=DCONJG(CK1SQ*(ANS(2)+CK2SQ*ANS(5))) 9693 ERH=DCONJG(CK2SQ*(ANS(1)+ANS(6))) 9694 EPH=-DCONJG(CK2SQ*(ANS(4)+ANS(6))) 9695 RETURN 9696 END 9697 SUBROUTINE GSHANK (START,DELA,SUM,NANS,SEED,IBK,BK,DELB) 9698C 9699C GSHANK INTEGRATES THE 6 SOMMERFELD INTEGRALS FROM START TO 9700C INFINITY (UNTIL CONVERGENCE) IN LAMBDA. AT THE BREAK POINT, BK, 9701C THE STEP INCREMENT MAY BE CHANGED FROM DELA TO DELB. SHANK S 9702C ALGORITHM TO ACCELERATE CONVERGENCE OF A SLOWLY CONVERGING SERIES 9703C IS USED 9704C 9705 IMPLICIT REAL*8(A-H,O-Z) 9706 SAVE 9707 COMPLEX*16 START,DELA,SUM,SEED,BK,DELB,A,B,Q1,Q2,ANS1,ANS2,A1,A2, 9708 1AS1,AS2,DEL,AA 9709 COMMON /CNTOUR/ A,B 9710 DIMENSION Q1(6,20), Q2(6,20), ANS1(6), ANS2(6), SUM(6), SEED(6) 9711 DATA CRIT/1.E-4/,MAXH/20/ 9712 RBK=DREAL(BK) 9713 DEL=DELA 9714 IBX=0 9715 IF (IBK.EQ.0) IBX=1 9716 DO 1 I=1,NANS 97171 ANS2(I)=SEED(I) 9718 B=START 97192 DO 20 INT=1,MAXH 9720 INX=INT 9721 A=B 9722 B=B+DEL 9723 IF (IBX.EQ.0.AND.DREAL(B).GE.RBK) GO TO 5 9724 CALL ROM1 (NANS,SUM,2) 9725 DO 3 I=1,NANS 97263 ANS1(I)=ANS2(I)+SUM(I) 9727 A=B 9728 B=B+DEL 9729 IF (IBX.EQ.0.AND.DREAL(B).GE.RBK) GO TO 6 9730 CALL ROM1 (NANS,SUM,2) 9731 DO 4 I=1,NANS 97324 ANS2(I)=ANS1(I)+SUM(I) 9733 GO TO 11 9734C HIT BREAK POINT. RESET SEED AND START OVER. 97355 IBX=1 9736 GO TO 7 97376 IBX=2 97387 B=BK 9739 DEL=DELB 9740 CALL ROM1 (NANS,SUM,2) 9741 IF (IBX.EQ.2) GO TO 9 9742 DO 8 I=1,NANS 97438 ANS2(I)=ANS2(I)+SUM(I) 9744 GO TO 2 97459 DO 10 I=1,NANS 974610 ANS2(I)=ANS1(I)+SUM(I) 9747 GO TO 2 974811 DEN=0. 9749 DO 18 I=1,NANS 9750 AS1=ANS1(I) 9751 AS2=ANS2(I) 9752 IF (INT.LT.2) GO TO 17 9753 DO 16 J=2,INT 9754 JM=J-1 9755 AA=Q2(I,JM) 9756 A1=Q1(I,JM)+AS1-2.*AA 9757 IF (DREAL(A1).EQ.0..AND.DIMAG(A1).EQ.0.) GO TO 12 9758 A2=AA-Q1(I,JM) 9759 A1=Q1(I,JM)-A2*A2/A1 9760 GO TO 13 976112 A1=Q1(I,JM) 976213 A2=AA+AS2-2.*AS1 9763 IF (DREAL(A2).EQ.0..AND.DIMAG(A2).EQ.0.) GO TO 14 9764 A2=AA-(AS1-AA)*(AS1-AA)/A2 9765 GO TO 15 976614 A2=AA 976715 Q1(I,JM)=AS1 9768 Q2(I,JM)=AS2 9769 AS1=A1 977016 AS2=A2 977117 Q1(I,INT)=AS1 9772 Q2(I,INT)=AS2 9773 AMG=ABS(DREAL(AS2))+ABS(DIMAG(AS2)) 9774 IF (AMG.GT.DEN) DEN=AMG 977518 CONTINUE 9776 DENM=1.E-3*DEN*CRIT 9777 JM=INT-3 9778 IF (JM.LT.1) JM=1 9779 DO 19 J=JM,INT 9780 DO 19 I=1,NANS 9781 A1=Q2(I,J) 9782 DEN=(ABS(DREAL(A1))+ABS(DIMAG(A1)))*CRIT 9783 IF (DEN.LT.DENM) DEN=DENM 9784 A1=Q1(I,J)-A1 9785 AMG=ABS(DREAL(A1))+ABS(DIMAG(A1)) 9786 IF (AMG.GT.DEN) GO TO 20 978719 CONTINUE 9788 GO TO 22 978920 CONTINUE 9790 WRITE(*,24) 9791 DO 21 I=1,NANS 979221 WRITE(*,25) Q1(I,INX),Q2(I,INX) 979322 DO 23 I=1,NANS 979423 SUM(I)=.5*(Q1(I,INX)+Q2(I,INX)) 9795 RETURN 9796C 979724 FORMAT (46H **** NO CONVERGENCE IN SUBROUTINE GSHANK ****) 979825 FORMAT (1X,1P10E12.5) 9799 END 9800 SUBROUTINE HANKEL (Z,H0,H0P) 9801C 9802C HANKEL EVALUATES HANKEL FUNCTION OF THE FIRST KIND, ORDER ZERO, 9803C AND ITS DERIVATIVE FOR COMPLEX ARGUMENT Z. 9804C 9805 IMPLICIT REAL*8(A-H,O-Z) 9806 SAVE 9807 COMPLEX*16 CLOGZ,H0,H0P,J0,J0P,P0Z,P1Z,Q0Z,Q1Z,Y0,Y0P,Z,ZI,ZI2,ZK, 9808 1FJ 9809 DIMENSION M(101), A1(25), A2(25), A3(25), A4(25), FJX(2) 9810 EQUIVALENCE (FJ,FJX) 9811 DATA PI,GAMMA,C1,C2,C3,P10,P20/3.141592654,.5772156649,-.024578509 9812 15,.3674669052,.7978845608,.0703125,.1121520996/ 9813 DATA Q10,Q20,P11,P21,Q11,Q21/.125,.0732421875,.1171875,.1441955566 9814 1,.375,.1025390625/ 9815 DATA POF,INIT/.7853981635,0/,FJX/0.,1./ 9816 IF (INIT.EQ.0) GO TO 5 98171 ZMS=Z*DCONJG(Z) 9818 IF (ZMS.NE.0.) GO TO 2 9819 WRITE(*,9) 9820 STOP 98212 IB=0 9822 IF (ZMS.GT.16.81) GO TO 4 9823 IF (ZMS.GT.16.) IB=1 9824C SERIES EXPANSION 9825 IZ=1.+ZMS 9826 MIZ=M(IZ) 9827 J0=(1.,0.) 9828 J0P=J0 9829 Y0=(0.,0.) 9830 Y0P=Y0 9831 ZK=J0 9832 ZI=Z*Z 9833 DO 3 K=1,MIZ 9834 ZK=ZK*A1(K)*ZI 9835 J0=J0+ZK 9836 J0P=J0P+A2(K)*ZK 9837 Y0=Y0+A3(K)*ZK 98383 Y0P=Y0P+A4(K)*ZK 9839 J0P=-.5*Z*J0P 9840 CLOGZ=LOG(.5*Z) 9841 Y0=(2.*J0*CLOGZ-Y0)/PI+C2 9842 Y0P=(2./Z+2.*J0P*CLOGZ+.5*Y0P*Z)/PI+C1*Z 9843 H0=J0+FJ*Y0 9844 H0P=J0P+FJ*Y0P 9845 IF (IB.EQ.0) RETURN 9846 Y0=H0 9847 Y0P=H0P 9848C ASYMPTOTIC EXPANSION 98494 ZI=1./Z 9850 ZI2=ZI*ZI 9851 P0Z=1.+(P20*ZI2-P10)*ZI2 9852 P1Z=1.+(P11-P21*ZI2)*ZI2 9853 Q0Z=(Q20*ZI2-Q10)*ZI 9854 Q1Z=(Q11-Q21*ZI2)*ZI 9855 ZK=EXP(FJ*(Z-POF))*SQRT(ZI)*C3 9856 H0=ZK*(P0Z+FJ*Q0Z) 9857 H0P=FJ*ZK*(P1Z+FJ*Q1Z) 9858 IF (IB.EQ.0) RETURN 9859 ZMS=COS((SQRT(ZMS)-4.)*31.41592654) 9860 H0=.5*(Y0*(1.+ZMS)+H0*(1.-ZMS)) 9861 H0P=.5*(Y0P*(1.+ZMS)+H0P*(1.-ZMS)) 9862 RETURN 9863C INITIALIZATION OF CONSTANTS 98645 PSI=-GAMMA 9865 DO 6 K=1,25 9866 A1(K)=-.25D0/(K*K) 9867 A2(K)=1.D0/(K+1.D0) 9868 PSI=PSI+1.D0/K 9869 A3(K)=PSI+PSI 98706 A4(K)=(PSI+PSI+1.D0/(K+1.D0))/(K+1.D0) 9871 DO 8 I=1,101 9872 TEST=1.D0 9873 DO 7 K=1,24 9874 INIT=K 9875 TEST=-TEST*I*A1(K) 9876 IF (TEST*A3(K).LT.1.D-6) GO TO 8 98777 CONTINUE 98788 M(I)=INIT 9879 GO TO 1 9880C 98819 FORMAT (34H ERROR - HANKEL NOT VALID FOR Z=0.) 9882 END 9883 SUBROUTINE LAMBDA (T,XLAM,DXLAM) 9884C 9885C COMPUTE INTEGRATION PARAMETER XLAM=LAMBDA FROM PARAMETER T. 9886C 9887 IMPLICIT REAL*8(A-H,O-Z) 9888 SAVE 9889 COMPLEX*16 A,B,XLAM,DXLAM 9890 COMMON /CNTOUR/ A,B 9891 DXLAM=B-A 9892 XLAM=A+DXLAM*T 9893 RETURN 9894 END 9895 SUBROUTINE ROM1 (N,SUM,NX) 9896C 9897C ROM1 INTEGRATES THE 6 SOMMERFELD INTEGRALS FROM A TO B IN LAMBDA. 9898C THE METHOD OF VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION IS USED. 9899C 9900 IMPLICIT REAL*8(A-H,O-Z) 9901 SAVE 9902 COMPLEX*16 A,B,SUM,G1,G2,G3,G4,G5,T00,T01,T10,T02,T11,T20 9903 COMMON /CNTOUR/ A,B 9904 DIMENSION SUM(6), G1(6), G2(6), G3(6), G4(6), G5(6), T01(6), T10(6 9905 1), T20(6) 9906 DATA NM,NTS,RX/131072,4,1.E-4/ 9907 LSTEP=0 9908 Z=0. 9909 ZE=1. 9910 S=1. 9911 EP=S/(1.E4*NM) 9912 ZEND=ZE-EP 9913 DO 1 I=1,N 99141 SUM(I)=(0.,0.) 9915 NS=NX 9916 NT=0 9917 CALL SAOA (Z,G1) 99182 DZ=S/NS 9919 IF (Z+DZ.LE.ZE) GO TO 3 9920 DZ=ZE-Z 9921 IF (DZ.LE.EP) GO TO 17 99223 DZOT=DZ*.5 9923 CALL SAOA (Z+DZOT,G3) 9924 CALL SAOA (Z+DZ,G5) 99254 NOGO=0 9926 DO 5 I=1,N 9927 T00=(G1(I)+G5(I))*DZOT 9928 T01(I)=(T00+DZ*G3(I))*.5 9929 T10(I)=(4.*T01(I)-T00)/3. 9930C TEST CONVERGENCE OF 3 POINT ROMBERG RESULT 9931 CALL TEST (DREAL(T01(I)),DREAL(T10(I)),TR,DIMAG(T01(I)),DIMAG(T10 9932 1(I)),TI,0.d0) 9933 IF (TR.GT.RX.OR.TI.GT.RX) NOGO=1 99345 CONTINUE 9935 IF (NOGO.NE.0) GO TO 7 9936 DO 6 I=1,N 99376 SUM(I)=SUM(I)+T10(I) 9938 NT=NT+2 9939 GO TO 11 99407 CALL SAOA (Z+DZ*.25,G2) 9941 CALL SAOA (Z+DZ*.75,G4) 9942 NOGO=0 9943 DO 8 I=1,N 9944 T02=(T01(I)+DZOT*(G2(I)+G4(I)))*.5 9945 T11=(4.*T02-T01(I))/3. 9946 T20(I)=(16.*T11-T10(I))/15. 9947C TEST CONVERGENCE OF 5 POINT ROMBERG RESULT 9948 CALL TEST (DREAL(T11),DREAL(T20(I)),TR,DIMAG(T11),DIMAG(T20(I)),TI 9949 1,0.d0) 9950 IF (TR.GT.RX.OR.TI.GT.RX) NOGO=1 99518 CONTINUE 9952 IF (NOGO.NE.0) GO TO 13 99539 DO 10 I=1,N 995410 SUM(I)=SUM(I)+T20(I) 9955 NT=NT+1 995611 Z=Z+DZ 9957 IF (Z.GT.ZEND) GO TO 17 9958 DO 12 I=1,N 995912 G1(I)=G5(I) 9960 IF (NT.LT.NTS.OR.NS.LE.NX) GO TO 2 9961 NS=NS/2 9962 NT=1 9963 GO TO 2 996413 NT=0 9965 IF (NS.LT.NM) GO TO 15 9966 IF (LSTEP.EQ.1) GO TO 9 9967 LSTEP=1 9968 CALL LAMBDA (Z,T00,T11) 9969 WRITE(*,18) T00 9970 WRITE(*,19) Z,DZ,A,B 9971 DO 14 I=1,N 997214 WRITE(*,19) G1(I),G2(I),G3(I),G4(I),G5(I) 9973 GO TO 9 997415 NS=NS*2 9975 DZ=S/NS 9976 DZOT=DZ*.5 9977 DO 16 I=1,N 9978 G5(I)=G3(I) 997916 G3(I)=G2(I) 9980 GO TO 4 998117 CONTINUE 9982 RETURN 9983C 998418 FORMAT (38H ROM1 -- STEP SIZE LIMITED AT LAMBDA =,1P2E12.5) 998519 FORMAT (1X,1P10E12.5) 9986 END 9987 SUBROUTINE SAOA (T,ANS) 9988C 9989C SAOA COMPUTES THE INTEGRAND FOR EACH OF THE 6 9990C SOMMERFELD INTEGRALS FOR SOURCE AND OBSERVER ABOVE GROUND 9991C 9992 IMPLICIT REAL*8(A-H,O-Z) 9993 SAVE 9994 COMPLEX*16 ANS,XL,DXL,CGAM1,CGAM2,B0,B0P,COM,CK1,CK1SQ,CKSM,CT1, 9995 1CT2,CT3,DGAM,DEN1,DEN2 9996 COMMON /EVLCOM/ CKSM,CT1,CT2,CT3,CK1,CK1SQ,CK2,CK2SQ,TKMAG,TSMAG,C 9997 1K1R,ZPH,RHO,JH 9998 DIMENSION ANS(6) 9999 CALL LAMBDA (T,XL,DXL) 10000 IF (JH.GT.0) GO TO 1 10001C BESSEL FUNCTION FORM 10002 CALL BESSEL (XL*RHO,B0,B0P) 10003 B0=2.*B0 10004 B0P=2.*B0P 10005 CGAM1=SQRT(XL*XL-CK1SQ) 10006 CGAM2=SQRT(XL*XL-CK2SQ) 10007 IF (DREAL(CGAM1).EQ.0.) CGAM1=DCMPLX(0.D0,-ABS(DIMAG(CGAM1))) 10008 IF (DREAL(CGAM2).EQ.0.) CGAM2=DCMPLX(0.D0,-ABS(DIMAG(CGAM2))) 10009 GO TO 2 10010C HANKEL FUNCTION FORM 100111 CALL HANKEL (XL*RHO,B0,B0P) 10012 COM=XL-CK1 10013 CGAM1=SQRT(XL+CK1)*SQRT(COM) 10014 IF (DREAL(COM).LT.0..AND.DIMAG(COM).GE.0.) CGAM1=-CGAM1 10015 COM=XL-CK2 10016 CGAM2=SQRT(XL+CK2)*SQRT(COM) 10017 IF (DREAL(COM).LT.0..AND.DIMAG(COM).GE.0.) CGAM2=-CGAM2 100182 XLR=XL*DCONJG(XL) 10019 IF (XLR.LT.TSMAG) GO TO 3 10020 IF (DIMAG(XL).LT.0.) GO TO 4 10021 XLR=DREAL(XL) 10022 IF (XLR.LT.CK2) GO TO 5 10023 IF (XLR.GT.CK1R) GO TO 4 100243 DGAM=CGAM2-CGAM1 10025 GO TO 7 100264 SIGN=1. 10027 GO TO 6 100285 SIGN=-1. 100296 DGAM=1./(XL*XL) 10030 DGAM=SIGN*((CT3*DGAM+CT2)*DGAM+CT1)/XL 100317 DEN2=CKSM*DGAM/(CGAM2*(CK1SQ*CGAM2+CK2SQ*CGAM1)) 10032 DEN1=1./(CGAM1+CGAM2)-CKSM/CGAM2 10033 COM=DXL*XL*EXP(-CGAM2*ZPH) 10034 ANS(6)=COM*B0*DEN1/CK1 10035 COM=COM*DEN2 10036 IF (RHO.EQ.0.) GO TO 8 10037 B0P=B0P/RHO 10038 ANS(1)=-COM*XL*(B0P+B0*XL) 10039 ANS(4)=COM*XL*B0P 10040 GO TO 9 100418 ANS(1)=-COM*XL*XL*.5 10042 ANS(4)=ANS(1) 100439 ANS(2)=COM*CGAM2*CGAM2*B0 10044 ANS(3)=-ANS(4)*CGAM2*RHO 10045 ANS(5)=COM*B0 10046 RETURN 10047 END 10048 10049