SUBROUTINE ADJINC 8,7
C
C ADJOINT SIMULATION WITH CENTRED DIFFERENCES AND CRANK-NICHOLSON DAMPING.
C
IMPLICIT NONE
INCLUDE 'champ.cdk'
INCLUDE 'chinc.cdk'
C
COMPLEX TERMZ,TERMS,TZ,TS,AVZ,AVS
C
REAL DMZ,DMS,DPZ,DPS,WKK,KX,DIV2
C
EXTERNAL CONADJ,GRADDT
NT = NSTOP
DO 1 IKX=1,IKTX
DO 1 IKY=1,IKTY
ZO(IKX,IKY)=CMPLX(0.,0.)
ZN(IKX,IKY)=CMPLX(0.,0.)
SO(IKX,IKY)=CMPLX(0.,0.)
SN(IKX,IKY)=CMPLX(0.,0.)
ZT(IKX,IKY) = ZTRAJ(IKX,IKY,NT+2)
ST(IKX,IKY) = STRAJ(IKX,IKY,NT+2)
1 CONTINUE
C
C SUBSEQUENT TIMESTEPS
C
DO 10 NT=NSTOP,2,-1
CALL GRADIN
DO 20 IKX=1,IKTX
DO 20 IKY=1,IKTY
ZT(IKX,IKY) = ZTRAJ(IKX,IKY,NT+1)
ST(IKX,IKY) = STRAJ(IKX,IKY,NT+1)
IF ( L(IKX+KTX,IKY).NE.1 ) GO TO 20
ZN(IKX,IKY) = ZN(IKX,IKY) + NZK(IKX,IKY)
SN(IKX,IKY) = SN(IKX,IKY) + NSK(IKX,IKY)
AVZ = ZO(IKX,IKY)
TZ = ZN(IKX,IKY)
AVS = SO(IKX,IKY)
TS = SN(IKX,IKY)
ZO(IKX,IKY) = ROBERT*AVZ
SO(IKX,IKY) = ROBERT*AVS
ZN(IKX,IKY) = (1-2*ROBERT)*AVZ
SN(IKX,IKY) = (1-2*ROBERT)*AVS
TZ = ROBERT*AVZ + TZ
TS = ROBERT*AVS + TS
DPZ = 1.+NU(IKX,IKY)*DELT
DPS = 1.+GAMMA(IKX,IKY)*DELT
RHZ(IKX,IKY) = TZ/DPZ
RHS(IKX,IKY) = TS/DPS
20 CONTINUE
C---------------------------------------------------------
CALL CONADJ(RHZ,RHS,NZK,NSK,IKTX,IKTY,KTX,KTY,
. 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---------------------------------------------------------
DO 40 IKX=1,IKTX
KX = FLOAT(IKX-1)
DO 40 IKY=1,IKTY
IF ( L(IKX+KTX,IKY).NE.1 ) GO TO 40
WKK = WN(IKX+KTX,IKY)
TERMZ = NZK(IKX,IKY)
. - BE*ZI*KX*RHZ(IKX,IKY)/WKK
TERMS = NSK(IKX,IKY)
C
DMZ = 1.-NU(IKX,IKY) *DELT
DMS = 1.-GAMMA(IKX,IKY)*DELT
C
ZO(IKX,IKY) = ZO(IKX,IKY) + DMZ*RHZ(IKX,IKY)
SO(IKX,IKY) = SO(IKX,IKY) + DMS*RHS(IKX,IKY)
ZN(IKX,IKY) = ZN(IKX,IKY) + D2*TERMZ
SN(IKX,IKY) = SN(IKX,IKY) + D2*TERMS
40 CONTINUE
10 CONTINUE
C
C FIRST TIMESTEP
C
NT = 1
CALL GRADIN
DO 60 IKX=1,IKTX
DO 60 IKY=1,IKTY
ZT(IKX,IKY) = ZTRAJ(IKX,IKY,2)
ST(IKX,IKY) = STRAJ(IKX,IKY,2)
IF ( L(IKX+KTX,IKY).NE.1 ) GO TO 60
ZN(IKX,IKY) = ZN(IKX,IKY) + NZK(IKX,IKY)
SN(IKX,IKY) = SN(IKX,IKY) + NSK(IKX,IKY)
60 CONTINUE
C---------------------------------------------------------
CALL CONADJ(ZN,SN,NZK,NSK,IKTX,IKTY,KTX,KTY,
. 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---------------------------------------------------------
DIV2=DELT/2.
DO 65 IKX=1,IKTX
DO 65 IKY=1,IKTY
RHZ(IKX,IKY)=DIV2*NZK(IKX,IKY)
RHS(IKX,IKY)=DIV2*NSK(IKX,IKY)
ZT(IKX,IKY) = ZTRAJ(IKX,IKY,1)
ST(IKX,IKY) = STRAJ(IKX,IKY,1)
65 CONTINUE
C---------------------------------------------------------
CALL CONADJ(ZN,SN,NZK,NSK,IKTX,IKTY,KTX,KTY,
. 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---------------------------------------------------------
DO 70 IKX=1,IKTX
KX = FLOAT(IKX-1)
DO 70 IKY=1,IKTY
IF ( L(IKX+KTX,IKY).NE.1 ) GO TO 70
WKK = WN(IKX+KTX,IKY)
TERMZ = -BE*ZI*KX*ZN(IKX,IKY)/WKK
ZO(IKX,IKY) = ZO(IKX,IKY) + ZN(IKX,IKY)
. + DIV2*(TERMZ + NZK(IKX,IKY))
SO(IKX,IKY) = SO(IKX,IKY) + SN(IKX,IKY)
. + DIV2*(NSK(IKX,IKY))
RHZ(IKX,IKY) = RHZ(IKX,IKY) + DIV2*TERMZ
70 CONTINUE
C
C---------------------------------------------------------
CALL CONADJ(RHZ,RHS,NZK,NSK,IKTX,IKTY,KTX,KTY,
. 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
C
DO 75 IKX=1,IKTX
KX = FLOAT(IKX-1)
DO 75 IKY=1,IKTY
IF ( L(IKX+KTX,IKY).NE.1 ) GO TO 75
WKK = WN(IKX+KTX,IKY)
TERMZ = -BE*ZI*KX*RHZ(IKX,IKY)/WKK
ZN(IKX,IKY) = RHZ(IKX,IKY)
. + DELT*(TERMZ+NZK(IKX,IKY))
SN(IKX,IKY) = RHS(IKX,IKY)
. + DELT*(NSK(IKX,IKY))
ZO(IKX,IKY) = ZO(IKX,IKY) + ZN(IKX,IKY)
SO(IKX,IKY) = SO(IKX,IKY) + SN(IKX,IKY)
75 CONTINUE
NT = -1
CALL GRADIN
DO 80 IKX=1,IKTX
DO 80 IKY=1,IKTY
IF ( L(IKX+KTX,IKY).NE.1 ) GO TO 80
ZO(IKX,IKY) = ZO(IKX,IKY) + NZK(IKX,IKY)
SO(IKX,IKY) = SO(IKX,IKY) + NSK(IKX,IKY)
80 CONTINUE
RETURN
END