SUBROUTINE CONADJ(ZK,SK,NZK,NSK,IKTX,IKTY,KTX,KTY,,9
. N,N2,L,PXLIM,LWRK,WORK,TRIGS,IFAX,
. FF1,FF2,FF3,UK,WK,UR,WR,ZR,SR,NZR,NSR,ZI,
. ZT,ST,NTR,NTK,U0)
C
C CALCULATES CONVOLUTION SUMS, CALLS FFT'S, ETC.
C
IMPLICIT NONE
INTEGER IKTX,IKTY,KTX,KTY,PXLIM
INTEGER IKX,IKY,L(PXLIM,IKTY),I,J
INTEGER KX,KY,IFAX(10),N,N2,LWRK
REAL KW,WORK(LWRK),TRIGS(N)
REAL FF1(N2,N2),FF2(N2,N2),FF3(N2,N2)
REAL UR(N,N),WR(N,N),NZR(N,N),SR(N,N),NSR(N,N)
REAL NTR(N,N),U0
REAL ZR(N,N),WEIGHT
COMPLEX NZK(IKTX,IKTY),NSK(IKTX,IKTY)
COMPLEX ZK(IKTX,IKTY), SK(IKTX,IKTY)
COMPLEX UK(IKTX,IKTY), WK(IKTX,IKTY)
COMPLEX ZT(IKTX,IKTY), ST(IKTX,IKTY)
COMPLEX NTK(IKTX,IKTY)
COMPLEX ZI, C1
EXTERNAL KR,RK
DO 10 IKX = 1, IKTX
KX = IKX-1
DO 10 IKY = 1, IKTY
KY = IKY - KTY - 1
KW = MAX( FLOAT(KX*KX+KY*KY) ,0.001 )
NZK(IKX,IKY) = CMPLX(0.,0.)
NSK(IKX,IKY) = CMPLX(0.,0.)
UK(IKX,IKY) = + L(IKX+KTX,IKY)*ZI*KY*ZT(IKX,IKY)/KW
WK(IKX,IKY) = - L(IKX+KTX,IKY)*ZI*KX*ZT(IKX,IKY)/KW
10 CONTINUE
CALL KR
(ZK,ZR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
cs CALL KR(SK,SR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
cs . FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
CALL KR
(UK,UR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
CALL KR
(WK,WR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
DO 20 I=1,N
DO 20 J=1,N
NZR(I,J) = (UR(I,J)+U0) * ZR(I,J)
cs NSR(I,J) = (UR(I,J)+U0) * SR(I,J)
20 CONTINUE
C
CALL RK
(NZR,NZK,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
cs CALL RK(NSR,NSK,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
cs . FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
C
DO 30 IKX = 1, IKTX
KX = IKX-1
DO 30 IKY = 1, IKTY
NZK(IKX,IKY) = + ZI*KX * NZK(IKX,IKY)
cs NSK(IKX,IKY) = + ZI*KX * NSK(IKX,IKY)
30 CONTINUE
C ------------------------------------------------------
DO 40 I=1,N
DO 40 J=1,N
UR(I,J) = WR(I,J) * ZR(I,J)
40 CONTINUE
C
CALL RK
(UR,UK,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
C
DO 50 IKX = 1, IKTX
DO 50 IKY = 1, IKTY
KY = IKY - KTY - 1
WEIGHT = L(IKX+KTX,IKY)*L(IKX+KTX,IKY)
C1 = + ZI*KY * UK(IKX,IKY)
CSL ADDITION OF THE NEGATIVE
NZK(IKX,IKY) = (NZK(IKX,IKY) + C1)*WEIGHT
50 CONTINUE
C ------------------------------------------------------
C ------------------------------------------------------
cs DO 72 I=1,N
cs DO 72 J=1,N
cs UR(I,J) = WR(I,J) * SR(I,J)
cs72 CONTINUE
cs CALL RK(UR,UK,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
cs . FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
cs DO 74 IKX = 1, IKTX
cs DO 74 IKY = 1, IKTY
cs KY = IKY - KTY - 1
cs WEIGHT = L(IKX+KTX,IKY)*L(IKX+KTX,IKY)
cs C1 = + ZI*KY * UK(IKX,IKY)
CSL ADDITION OF THE NEGATIVE
cs NSK(IKX,IKY) = (NSK(IKX,IKY) + C1)*WEIGHT
cs74 CONTINUE
C ------------------------------------------------------
CSL ------------------------------------------------------
DO 80 IKX = 1, IKTX
KX = IKX-1
DO 80 IKY = 1, IKTY
KY = IKY - KTY - 1
UK(IKX,IKY) = + L(IKX+KTX,IKY)*ZI*KY*ZT(IKX,IKY)
WK(IKX,IKY) = - L(IKX+KTX,IKY)*ZI*KX*ZT(IKX,IKY)
80 CONTINUE
C
C
CALL KR
(UK,UR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
CALL KR
(WK,WR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
DO 90 I=1,N
DO 90 J=1,N
NTR(I,J) = UR(I,J) * ZR(I,J)
90 CONTINUE
C
CALL RK
(NTR,NTK,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
DO 93 IKX = 1, IKTX
KX = IKX-1
DO 93 IKY = 1, IKTY
NTK(IKX,IKY) = + ZI*KX * NTK(IKX,IKY)
93 CONTINUE
DO 95 I=1,N
DO 95 J=1,N
UR(I,J) = WR(I,J) * ZR(I,J)
95 CONTINUE
C
CALL RK
(UR,UK,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
C
DO 100 IKX = 1, IKTX
KX = IKX-1
DO 100 IKY = 1, IKTY
KY = IKY - KTY - 1
KW = MAX( FLOAT(KX*KX+KY*KY) ,0.001 )
WEIGHT = L(IKX+KTX,IKY)*L(IKX+KTX,IKY)/KW
C1 = + ZI*KY * UK(IKX,IKY)
NZK(IKX,IKY) = NZK(IKX,IKY) - (NTK(IKX,IKY) + C1)*WEIGHT
100 CONTINUE
CSL ------------------------------------------------------
CSL ------------------------------------------------------
cs DO 125 IKX = 1, IKTX
cs KX = IKX-1
cs DO 125 IKY = 1, IKTY
cs KY = IKY - KTY - 1
cs UK(IKX,IKY) = + L(IKX+KTX,IKY)*ZI*KY*ST(IKX,IKY)
cs WK(IKX,IKY) = - L(IKX+KTX,IKY)*ZI*KX*ST(IKX,IKY)
cs125 CONTINUE
C
C
cs CALL KR(UK,UR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
cs . FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
cs CALL KR(WK,WR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
cs . FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
cs DO 130 I=1,N
cs DO 130 J=1,N
cs NTR(I,J) = UR(I,J) * SR(I,J)
cs130 CONTINUE
C
cs CALL RK(NTR,NTK,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
cs . FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
cs DO 133 IKX = 1, IKTX
cs KX = IKX-1
cs DO 133 IKY = 1, IKTY
cs NTK(IKX,IKY) = + ZI*KX * NTK(IKX,IKY)
cs133 CONTINUE
cs DO 135 I=1,N
cs DO 135 J=1,N
cs UR(I,J) = WR(I,J) * SR(I,J)
cs135 CONTINUE
C
cs CALL RK(UR,UK,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
cs . FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
C
cs DO 140 IKX = 1, IKTX
cs KX = IKX-1
cs DO 140 IKY = 1, IKTY
cs KY = IKY - KTY - 1
cs KW = MAX( FLOAT(KX*KX+KY*KY) ,0.001 )
cs WEIGHT = L(IKX+KTX,IKY)*L(IKX+KTX,IKY)/KW
cs C1 = + ZI*KY * UK(IKX,IKY)
cs NZK(IKX,IKY) = NZK(IKX,IKY) - (NTK(IKX,IKY) + C1)*WEIGHT
cs140 CONTINUE
CSL ------------------------------------------------------
RETURN
END