|
"James Tursa" <aclassyguy_with_a_k_not_a_c@hotmail.com> wrote in message <hcpepd$rfs$1@fred.mathworks.com>...
> Post one of your short functions and we can offer specif advice. Basically, you can make a module with the common block stuff in the module. Add a flag to the module that remembers if the data in the common block is initialized or not. Add a function to the module that initializes the data if the flag is not set. Then have your function call that module function first thing upon entry. *However*, this will not work if the individual functions you are creating have to communicate amongst themselves. i.e., is it your intention that changes in common block variables in one function affect the common block variables of another function?
>
> James Tursa
here is a sample file
SUBROUTINE FFLD (THET,PHI,ETH,EPH)
C ***
C DOUBLE PRECISION 6/4/85
C
INCLUDE 'NEC2DPAR.INC'
IMPLICIT REAL*8(A-H,O-Z)
C ***
C
C FFLD CALCULATES THE FAR ZONE RADIATED ELECTRIC FIELDS,
C THE FACTOR EXP(J*K*R)/(R/LAMDA) NOT INCLUDED
C
COMPLEX*16 CIX,CIY,CIZ,EXA,ETH,EPH,CONST,CCX,CCY,CCZ,CDP,CUR
COMPLEX*16 ZRATI,ZRSIN,RRV,RRH,RRV1,RRH1,RRV2,RRH2,ZRATI2,TIX,TIY
1,TIZ,T1,ZSCRN,EX,EY,EZ,GX,GY,GZ,FRATI
COMMON /DATA/ X(MAXSEG),Y(MAXSEG),Z(MAXSEG),SI(MAXSEG),BI(MAXSEG),
&ALP(MAXSEG),BET(MAXSEG),WLAM,ICON1(2*MAXSEG),ICON2(2*MAXSEG),
&ITAG(2*MAXSEG),ICONX(MAXSEG),LD,N1,N2,N,NP,M1,M2,M,MP,IPSYM
COMMON /ANGL/ SALP(MAXSEG)
COMMON /CRNT/ AIR(MAXSEG),AII(MAXSEG),BIR(MAXSEG),BII(MAXSEG),
&CIR(MAXSEG),CII(MAXSEG),CUR(3*MAXSEG)
COMMON /GND/ZRATI,ZRATI2,FRATI,T1,T2,CL,CH,SCRWL,SCRWR,NRADL,
&KSYMP,IFAR,IPERF
DIMENSION CAB(1), SAB(1), CONSX(2)
EQUIVALENCE (CAB,ALP), (SAB,BET), (CONST,CONSX)
DATA PI,TP,ETA/3.141592654D+0,6.283185308D+0,376.73/
DATA CONSX/0.,-29.97922085D+0/
PHX=-SIN(PHI)
PHY=COS(PHI)
ROZ=COS(THET)
ROZS=ROZ
THX=ROZ*PHY
THY=-ROZ*PHX
THZ=-SIN(THET)
ROX=-THZ*PHY
ROY=THZ*PHX
IF (N.EQ.0) GO TO 20
C
C LOOP FOR STRUCTURE IMAGE IF ANY
C
DO 19 K=1,KSYMP
C
C CALCULATION OF REFLECTION COEFFECIENTS
C
IF (K.EQ.1) GO TO 4
IF (IPERF.NE.1) GO TO 1
C
C FOR PERFECT GROUND
C
RRV=-(1.,0.)
RRH=-(1.,0.)
GO TO 2
C
C FOR INFINITE PLANAR GROUND
C
1 ZRSIN=SQRT(1.-ZRATI*ZRATI*THZ*THZ)
RRV=-(ROZ-ZRATI*ZRSIN)/(ROZ+ZRATI*ZRSIN)
RRH=(ZRATI*ROZ-ZRSIN)/(ZRATI*ROZ+ZRSIN)
2 IF (IFAR.LE.1) GO TO 3
C
C FOR THE CLIFF PROBLEM, TWO REFLCTION COEFFICIENTS CALCULATED
C
RRV1=RRV
RRH1=RRH
TTHET=TAN(THET)
IF (IFAR.EQ.4) GO TO 3
ZRSIN=SQRT(1.-ZRATI2*ZRATI2*THZ*THZ)
RRV2=-(ROZ-ZRATI2*ZRSIN)/(ROZ+ZRATI2*ZRSIN)
RRH2=(ZRATI2*ROZ-ZRSIN)/(ZRATI2*ROZ+ZRSIN)
DARG=-TP*2.*CH*ROZ
3 ROZ=-ROZ
CCX=CIX
CCY=CIY
CCZ=CIZ
4 CIX=(0.,0.)
CIY=(0.,0.)
CIZ=(0.,0.)
C
C LOOP OVER STRUCTURE SEGMENTS
C
DO 17 I=1,N
OMEGA=-(ROX*CAB(I)+ROY*SAB(I)+ROZ*SALP(I))
EL=PI*SI(I)
SILL=OMEGA*EL
TOP=EL+SILL
BOT=EL-SILL
IF (ABS(OMEGA).LT.1.D-7) GO TO 5
A=2.*SIN(SILL)/OMEGA
GO TO 6
5 A=(2.-OMEGA*OMEGA*EL*EL/3.)*EL
6 IF (ABS(TOP).LT.1.D-7) GO TO 7
TOO=SIN(TOP)/TOP
GO TO 8
7 TOO=1.-TOP*TOP/6.
8 IF (ABS(BOT).LT.1.D-7) GO TO 9
BOO=SIN(BOT)/BOT
GO TO 10
9 BOO=1.-BOT*BOT/6.
10 B=EL*(BOO-TOO)
C=EL*(BOO+TOO)
RR=A*AIR(I)+B*BII(I)+C*CIR(I)
RI=A*AII(I)-B*BIR(I)+C*CII(I)
ARG=TP*(X(I)*ROX+Y(I)*ROY+Z(I)*ROZ)
IF (K.EQ.2.AND.IFAR.GE.2) GO TO 11
EXA=DCMPLX(COS(ARG),SIN(ARG))*DCMPLX(RR,RI)
C
C SUMMATION FOR FAR FIELD INTEGRAL
C
CIX=CIX+EXA*CAB(I)
CIY=CIY+EXA*SAB(I)
CIZ=CIZ+EXA*SALP(I)
GO TO 17
C
C CALCULATION OF IMAGE CONTRIBUTION IN CLIFF AND GROUND SCREEN
C PROBLEMS.
C
11 DR=Z(I)*TTHET
C
C SPECULAR POINT DISTANCE
C
D=DR*PHY+X(I)
IF (IFAR.EQ.2) GO TO 13
D=SQRT(D*D+(Y(I)-DR*PHX)**2)
IF (IFAR.EQ.3) GO TO 13
IF ((SCRWL-D).LT.0.) GO TO 12
C
C RADIAL WIRE GROUND SCREEN REFLECTION COEFFICIENT
C
D=D+T2
ZSCRN=T1*D*LOG(D/T2)
ZSCRN=(ZSCRN*ZRATI)/(ETA*ZRATI+ZSCRN)
ZRSIN=SQRT(1.-ZSCRN*ZSCRN*THZ*THZ)
RRV=(ROZ+ZSCRN*ZRSIN)/(-ROZ+ZSCRN*ZRSIN)
RRH=(ZSCRN*ROZ+ZRSIN)/(ZSCRN*ROZ-ZRSIN)
GO TO 16
12 IF (IFAR.EQ.4) GO TO 14
IF (IFAR.EQ.5) D=DR*PHY+X(I)
13 IF ((CL-D).LE.0.) GO TO 15
14 RRV=RRV1
RRH=RRH1
GO TO 16
15 RRV=RRV2
RRH=RRH2
ARG=ARG+DARG
16 EXA=DCMPLX(COS(ARG),SIN(ARG))*DCMPLX(RR,RI)
C
C CONTRIBUTION OF EACH IMAGE SEGMENT MODIFIED BY REFLECTION COEF. ,
C FOR CLIFF AND GROUND SCREEN PROBLEMS
C
TIX=EXA*CAB(I)
TIY=EXA*SAB(I)
TIZ=EXA*SALP(I)
CDP=(TIX*PHX+TIY*PHY)*(RRH-RRV)
CIX=CIX+TIX*RRV+CDP*PHX
CIY=CIY+TIY*RRV+CDP*PHY
CIZ=CIZ-TIZ*RRV
17 CONTINUE
IF (K.EQ.1) GO TO 19
IF (IFAR.GE.2) GO TO 18
C
C CALCULATION OF CONTRIBUTION OF STRUCTURE IMAGE FOR INFINITE GROUND
C
CDP=(CIX*PHX+CIY*PHY)*(RRH-RRV)
CIX=CCX+CIX*RRV+CDP*PHX
CIY=CCY+CIY*RRV+CDP*PHY
CIZ=CCZ-CIZ*RRV
GO TO 19
18 CIX=CIX+CCX
CIY=CIY+CCY
CIZ=CIZ+CCZ
19 CONTINUE
IF (M.GT.0) GO TO 21
ETH=(CIX*THX+CIY*THY+CIZ*THZ)*CONST
EPH=(CIX*PHX+CIY*PHY)*CONST
RETURN
20 CIX=(0.,0.)
CIY=(0.,0.)
CIZ=(0.,0.)
21 ROZ=ROZS
C
C ELECTRIC FIELD COMPONENTS
C
RFL=-1.
DO 25 IP=1,KSYMP
RFL=-RFL
RRZ=ROZ*RFL
CALL FFLDS (ROX,ROY,RRZ,CUR(N+1),GX,GY,GZ)
IF (IP.EQ.2) GO TO 22
EX=GX
EY=GY
EZ=GZ
GO TO 25
22 IF (IPERF.NE.1) GO TO 23
GX=-GX
GY=-GY
GZ=-GZ
GO TO 24
23 RRV=SQRT(1.-ZRATI*ZRATI*THZ*THZ)
RRH=ZRATI*ROZ
RRH=(RRH-RRV)/(RRH+RRV)
RRV=ZRATI*RRV
RRV=-(ROZ-RRV)/(ROZ+RRV)
ETH=(GX*PHX+GY*PHY)*(RRH-RRV)
GX=GX*RRV+ETH*PHX
GY=GY*RRV+ETH*PHY
GZ=GZ*RRV
24 EX=EX+GX
EY=EY+GY
EZ=EZ-GZ
25 CONTINUE
EX=EX+CIX*CONST
EY=EY+CIY*CONST
EZ=EZ+CIZ*CONST
ETH=EX*THX+EY*THY+EZ*THZ
EPH=EX*PHX+EY*PHY
RETURN
END
|
Feed for this Thread