home *** CD-ROM | disk | FTP | other *** search
-
- SUBROUTINE MASKEF(X,Y,XQ,YQ,PHCRD) 2417
-
- c include 'tcommon.for'
- %include tcommon.for
-
- DIMENSION ATENF(5) 2437
- DATA ATENF/100.,30.,25.,50.,500./ 2438
- C ...OBJECT AT XQ,YQ IS PHASING OBJECT AT X,Y. 2439
- C ...PHCRD WILL BE % REDUCTION DUE TO MASKING. 2440
- C ...INTERVENING OBJECTS AND THEIR RELATIVE MASKING EFFECTS: 2441
- C ... * 100 2442
- C ... K,R 30 2443
- C ... G 25 2444
- C ... HOLE500 2445
- PHCRD=0. 2446
- LNDX=1 2447
- SUMAX=0. 2448
- SUMACT=0. 2449
- IF(NSTARS.EQ.0)GO TO 100 2450
- DO 50 I=1,NSTARS 2451
- IF(STARS(I,1).EQ.0)GO TO 50 2452
- CALL GETBRG(A1,XQ,STARS(I,1),YQ,STARS(I,2),VPX,VPY) 2453
- CALL GETBRG(A2,STARS(I,1),X,STARS(I,2),Y,VPX,VPY) 2454
- D1=VPX*VPX+VPY*VPY 2455
- D2=0. 2456
- IF(A1.NE.0.)D2=360.-A1 2457
- A2=A2+D2 2458
- IF(A2.GE.360.)A2=A2-360. 2459
- IF(A2.GE.45..AND.A2.LE.315.)GO TO 50 2460
- SUMAX=SUMAX+ATENF(LNDX) 2461
- D2=SIND(A2) 2462
- D2=1.-D2*D2 2463
- D2=D2/2.+RAD(I)/(D1+D1) 2464
- IF(D2.GT.1.)D2=1. 2465
- SUMACT=SUMACT+D2*ATENF(LNDX) 2466
- 50 CONTINUE 2467
- 100 IF(KLNGNS.EQ.0)GO TO 200 2468
- LNDX=2 2469
- DO 150 I=1,KLNGNS 2470
- IF(XKL(I,1).EQ.0)GO TO 150 2471
- IF(XKL(I,1).EQ.X.AND.XKL(I,2).EQ.Y)GO TO 150 2472
- IF(XKL(I,1).EQ.XQ.AND.XKL(I,2).EQ.YQ)GO TO 150 2473
- CALL GETBRG(A1,XQ,XKL(I,1),YQ,XKL(I,2),VPX,VPY) 2474
- CALL GETBRG(A2,XKL(I,1),X,XKL(I,2),Y,VPX,VPY) 2475
- D1=VPX*VPX+VPY*VPY 2476
- D2=0. 2477
- IF(A1.NE.0.)D2=360.-A1 2478
- A2=A2+D2 2479
- IF(A2.GE.360.)A2=A2-360. 2480
- IF(A2.GE.45..AND.A2.LE.315.)GO TO 150 2481
- SUMAX=SUMAX+ATENF(LNDX) 2482
- D2=SIND(A2) 2483
- D2=1.-D2*D2 2484
- D2=D2/2.+RADKK/(D1+D1) 2485
- IF(D2.GT.1.)D2=1. 2486
- SUMACT=SUMACT+D2*ATENF(LNDX) 2487
- 150 CONTINUE 2488
- 200 IF(NROM.EQ.0)GO TO 300 2489
- LNDX=2 2490
- DO 250 I=1,NROM 2491
- IF(XROM(I,1).EQ.0)GO TO 250 2492
- IF(XROM(I,1).EQ.X.AND.XROM(I,2).EQ.Y)GO TO 250 2493
- CALL GETBRG(A1,XQ,XROM(I,1),YQ,XROM(I,2),VPX,VPY) 2494
- CALL GETBRG(A2,XROM(I,1),X,XROM(I,2),Y,VPX,VPY) 2495
- D1=VPX*VPX+VPY*VPY 2496
- D2=0. 2497
- IF(A1.NE.0.)D2=360.-A1 2498
- A2=A2+D2 2499
- IF(A2.GE.360.)A2=A2-360. 2500
- IF(A2.GE.45..AND.A2.LE.315.)GO TO 250 2501
- SUMAX=SUMAX+ATENF(LNDX) 2502
- D2=SIND(A2) 2503
- D2=1.-D2*D2 2504
- D2=D2/2.+RADKK/(D1+D1) 2505
- IF(D2.GT.1.)D2=1. 2506
- SUMACT=SUMACT+D2*ATENF(LNDX) 2507
- 250 CONTINUE 2508
- 300 IF(IGH.EQ.0)GO TO 400 2509
- IF(GHOST(1).EQ.XQ.AND.GHOST(2).EQ.YQ)GO TO 400 2510
- LNDX=3 2511
- CALL GETBRG(A1,XQ,GHOST(1),YQ,GHOST(2),VPX,VPY) 2512
- CALL GETBRG(A2,GHOST(1),X,GHOST(2),Y,VPX,VPY) 2513
- D1=VPX*VPX+VPY*VPY 2514
- D2=0. 2515
- IF(A1.NE.0.)D2=360.-A1 2516
- A2=A2+D2 2517
- IF(A2.GE.360.)A2=A2-360. 2518
- IF(A2.GE.45..AND.A2.LE.315.)GO TO 400 2519
- SUMAX=SUMAX+ATENF(LNDX) 2520
- D2=SIND(A2) 2521
- D2=1.-D2*D2 2522
- D2=D2/2.+RADEG/(D1+D1) 2523
- IF(D2.GT.1.)D2=1. 2524
- SUMACT=SUMACT+D2*ATENF(LNDX) 2525
- 400 IF (IBASE.EQ.0)GO TO 500 2526
- LNDX=4 2527
- CALL GETBRG(A1,XQ,BASE(1),YQ,BASE(2),VPX,VPY) 2528
- CALL GETBRG(A2,BASE(1),X,BASE(2),Y,VPX,VPY) 2529
- D1=VPX*VPX+VPY*VPY 2530
- D2=0. 2531
- IF(A1.NE.0.)D2=360.-A1 2532
- A2=A2+D2 2533
- IF(A2.GE.360.)A2=A2-360. 2534
- IF(A2.GE.45..AND.A2.LE.315.)GO TO 500 2535
- SUMAX=SUMAX+ATENF(LNDX) 2536
- D2=SIND(A2) 2537
- D2=1.-D2*D2 2538
- D2=D2/2.+RADEB/(D1+D1) 2539
- IF(D2.GT.1.)D2=1. 2540
- SUMACT=SUMACT+D2*ATENF(LNDX) 2541
- 500 IF(IHOLE.EQ.0)GO TO 999 2542
- LNDX=5 2543
- XX=IHOLE 2544
- YY=JHOLE 2545
- CALL GETBRG(A1,XQ,XX,YQ,YY,VPX,VPY) 2546
- CALL GETBRG(A2,XX,X,YY,Y,VPX,VPY) 2547
- D1=VPX*VPX+VPY*VPY 2548
- D2=0. 2549
- IF(A1.NE.0.)D2=360.-A1 2550
- A2=A2+D2 2551
- IF(A2.GE.360.)A2=A2-360. 2552
- IF(A2.GE.45..AND.A2.LE.315.)GO TO 999 2553
- SUMAX=SUMAX+ATENF(LNDX) 2554
- D2=SIND(A2) 2555
- D2=1.-D2*D2 2556
- D2=D2/2.+HOLRAD/(D1) 2557
- IF(D2.GT.1.)D2=1. 2558
- SUMACT=SUMACT+D2*ATENF(LNDX) 2559
- 999 IF(SUMAX.EQ.0.)GO TO 1000 2560
- PHCRD=SUMACT/SUMAX 2561
- 1000 RETURN 2562
- END 2563
