SUBROUTINE MODDIR(JX) 11,17
C
C DIRECT SIMULATION WITH CENTRED DIFFERENCES
C AND CRANK-NICHOLSON DAMPING.
C
IMPLICIT NONE
include 'champ.cdk'
C
COMPLEX :: TERMZ,TERMS,TZ,TS,AVZ,AVS
REAL(kind=single) :: WKK,KX,KY,KW,DMZ,DMS,DPZ,DPS,JX
REAL (kind=single) :: FOREFF,RA(10000),AMRA
INTEGER :: IO,NOUT,IR
EXTERNAL CONVOL,SPEC,KR,FIELD,COUTDT
C
open(1,file='random.io',status='old')
read(1,103) (ra(ikx),ikx=1,10000)
close(1)
103 format(8f10.7)
AMRA = 0.0
IR = 0
NOUT = 3000
JX = 0.
C ---------------------- RECORD OUTPUT ----------------------
if (grflag.eq.1) then
NOUT = NSTOP/(NSORTIE-1)
open(10,file='spec.dat',status='unknown')
open(11,file='tour.dat',status='unknown')
open(111,file='tourr.dat',status='unknown')
open(13,file='u.dat',status='unknown')
open(14,file='w.dat',status='unknown')
open(15,file='trac.dat',status='unknown')
write(11,*) N,NP,NSORTIE
write(13,*) N,NP,NSORTIE
write(14,*) N,NP,NSORTIE
write(15,*) N,NP,NSORTIE
endif
C -----------------------------------------------------------
IF (TEFLAG.EQ.1) THEN
open (18,file='traj.io',form='unformatted')
ENDIF
C -----------------------------------------------------------
NT = 0
IO = 0
DO IKX=1,IKTX
DO IKY=1,IKTY
IF (L(IKX+KTX,IKY).NE.1) THEN
ZO(IKX,IKY) = 0.0
SO(IKX,IKY) = 0.0
ENDIF
ENDDO
ENDDO
C ---------------------- RECORD OUTPUT ----------------------
IF (GRFLAG.EQ.1) THEN
CALL SPEC(ZO,SO,IKTX,IKTY,KTX,KTY,NS,SPZ,0,AJ,BJ,
. GRFLAG,NT*DELT)
CALL KR(ZO,ZR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
write(11,99) ((ZR(IW,JW),IW=1,N),JW=1,NP)
DO IW =1,N
DO JW = 1,NP
write(111,88) ZR(IW,JW)
ENDDO
ENDDO
call FIELD(ZO,UK,TR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI,PXLIM,L,3)
DO IW=1,N
DO JW=1,NP
CHAMP(IW,JW) = TR(IW,JW)
ENDDO
ENDDO
write(13,99) ((CHAMP(IW,JW),IW=1,N),JW=1,NP)
call FIELD(ZO,WK,TR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI,PXLIM,L,4)
DO IW=1,N
DO JW=1,NP
CHAMP(IW,JW) = TR(IW,JW)
ENDDO
ENDDO
write(14,99) ((CHAMP(IW,JW),IW=1,N),JW=1,NP)
CALL KR(SO,SR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
DO IW=1,N
DO JW=1,NP
CHAMP(IW,JW) = SR(IW,JW)
ENDDO
ENDDO
write(15,99) ((CHAMP(IW,JW),IW=1,N),JW=1,NP)
ENDIF
C -----------------------------------------------------------
C
C FIRST TIMESTEP
C
IF(TEFLAG.EQ.1) write(18) ((ZO(IKX,IKY),IKX=1,IKTX),IKY=1,IKTY)
IF(TRFLAG.EQ.1) THEN
c + IF(NSTOP+2.GT.NTRAJ) THEN
c + PRINT*,'NSTOP+2.GT.NTRAJ'
c + PRINT*,'NSTOP,NTRAJ',NSTOP,NTRAJ
c + STOP
c + ENDIF
DO IKX=1,IKTX
DO IKY=1,IKTY
ZTRAJ(IKX,IKY,1)=ZO(IKX,IKY)
STRAJ(IKX,IKY,1)=SO(IKX,IKY)
ENDDO
ENDDO
ENDIF
IF(JXFLAG.EQ.1) THEN
NT = -1
CALL COUTDT(ZO,SO,JX)
ENDIF
NT = 1
C---------------------------------------------------------
CALL CONVOL(ZO,SO,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,U0)
C---------------------------------------------------------
DO IKX=1,IKTX
KX = FLOAT(IKX-1)
DO IKY=1,IKTY
IF ( L(IKX+KTX,IKY).eq.1 ) then
WKK = WN(IKX+KTX,IKY)
TERMZ = NZK(IKX,IKY)
. + BE*ZI*KX*ZO(IKX,IKY)/WKK
TERMS = NSK(IKX,IKY)
C
RHZ(IKX,IKY) = TERMZ
RHS(IKX,IKY) = TERMS
ZN(IKX,IKY) = ZO(IKX,IKY) + DELT*TERMZ
SN(IKX,IKY) = SO(IKX,IKY) + DELT*TERMS
end if
end do
end do
C
IF(TEFLAG.EQ.1) write(18) ((ZN(IKX,IKY),IKX=1,IKTX),IKY=1,IKTY)
IF(TRFLAG.EQ.1) THEN
DO IKX=1,IKTX
DO IKY=1,IKTY
ZTRAJ(IKX,IKY,2)=ZN(IKX,IKY)
STRAJ(IKX,IKY,2)=SN(IKX,IKY)
ENDDO
ENDDO
ENDIF
C---------------------------------------------------------
CALL CONVOL(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,U0)
C---------------------------------------------------------
c
C
Do IKX=1,IKTX
KX = FLOAT(IKX-1)
DO IKY=1,IKTY
IF ( L(IKX+KTX,IKY).eq.1 ) then
WKK = WN(IKX+KTX,IKY)
TERMZ = NZK(IKX,IKY)
. + BE*ZI*KX*ZN(IKX,IKY)/WKK
TERMS = NSK(IKX,IKY)
ZN(IKX,IKY)=ZO(IKX,IKY)+DELT*(TERMZ+RHZ(IKX,IKY))/2.
SN(IKX,IKY)=SO(IKX,IKY)+DELT*(TERMS+RHS(IKX,IKY))/2.
end if
end do
end do
IF(TEFLAG.EQ.1) write(18) ((ZN(IKX,IKY),IKX=1,IKTX),IKY=1,IKTY)
IF(TRFLAG.EQ.1) THEN
DO IKX=1,IKTX
DO IKY=1,IKTY
ZTRAJ(IKX,IKY,3)=ZN(IKX,IKY)
STRAJ(IKX,IKY,3)=SN(IKX,IKY)
ENDDO
ENDDO
ENDIF
IF(JXFLAG.EQ.1) THEN
CALL COUTDT(ZN,SN,JX)
ENDIF
C
C SUBSEQUENT TIMESTEPS
C
DO 50 NT=2,NSTOP
C
C---------------------------------------------------------
CALL CONVOL(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,U0)
C---------------------------------------------------------
c
C ------------------ FORCING AT K = 3 -----------------
IF(FORCING.NE.0.) THEN
IR=IR+1
FOREFF=FORCING+AMRA*RA(IR)
NZK(KF+1,KTY+1)=NZK(KF+1,KTY+1) + FOREFF*CMPLX(1.,0.)
NZK(1,KF+KTY+1)=NZK(1,KF+KTY+1) + FOREFF*CMPLX(1.,0.)
ENDIF
C
c
DO IKX=1,IKTX
KX = FLOAT(IKX-1)
DO IKY=1,IKTY
IF ( L(IKX+KTX,IKY).eq.1 ) then
WKK = WN(IKX+KTX,IKY)
TERMZ = NZK(IKX,IKY)
. + BE*ZI*KX*ZN(IKX,IKY)/WKK
TERMS = NSK(IKX,IKY)
C
DPZ = 1.+NU(IKX,IKY) *DELT
DMZ = 1.-NU(IKX,IKY) *DELT
DPS = 1.+GAMMA(IKX,IKY)*DELT
DMS = 1.-GAMMA(IKX,IKY)*DELT
TZ = ( ZO(IKX,IKY)*DMZ + D2*TERMZ )/DPZ
TS = ( SO(IKX,IKY)*DMS + D2*TERMS )/DPS
C
AVZ = ZN(IKX,IKY) + ROBERT* (TZ -
. 2.*ZN(IKX,IKY) + ZO(IKX,IKY))
AVS = SN(IKX,IKY) + ROBERT* (TS -
. 2.*SN(IKX,IKY) + SO(IKX,IKY))
C
ZO(IKX,IKY) = AVZ
SO(IKX,IKY) = AVS
ZN(IKX,IKY) = TZ
SN(IKX,IKY) = TS
end if
end do
end do
C
C
C
IF(TEFLAG.EQ.1) write(18) ((ZN(IKX,IKY),IKX=1,IKTX),IKY=1,IKTY)
IF(TRFLAG.EQ.1) THEN
DO IKX=1,IKTX
DO IKY=1,IKTY
ZTRAJ(IKX,IKY,NT+2)=ZN(IKX,IKY)
STRAJ(IKX,IKY,NT+2)=SN(IKX,IKY)
ENDDO
ENDDO
ENDIF
IF(JXFLAG.EQ.1) THEN
CALL COUTDT(ZN,SN,JX)
ENDIF
C ---------------------- RECORD OUTPUT ----------------------
IF (GRFLAG.EQ.1.and.mod(nt,nout).eq.0) THEN
c
C print*,' '
print*,'N, NSTOP: ',NT, NSTOP
CALL SPEC(ZN,SN,IKTX,IKTY,KTX,KTY,NS,SPZ,0,AJ,BJ,
. GRFLAG,NT*DELT)
C
PRINT*,' '
C
CALL KR(ZN,ZR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
write(11,99) ((ZR(IW,JW),IW=1,N),JW=1,NP)
DO IW=1,N
DO JW=1,NP
write(111,88) ZR(IW,JW)
ENDDO
ENDDO
call FIELD(ZN,UK,TR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI,PXLIM,L,3)
DO IW=1,N
DO JW=1,NP
CHAMP(IW,JW) = TR(IW,JW)
ENDDO
ENDDO
write(13,99) ((CHAMP(IW,JW),IW=1,N),JW=1,NP)
call FIELD(ZN,WK,TR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
. FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI,PXLIM,L,4)
DO IW=1,N
DO JW=1,NP
CHAMP(IW,JW) = TR(IW,JW)
ENDDO
ENDDO
write(14,99) ((CHAMP(IW,JW),IW=1,N),JW=1,NP)
DO IW=1,N
DO JW=1,NP
CHAMP(IW,JW) = SR(IW,JW)
ENDDO
ENDDO
write(15,99) ((CHAMP(IW,JW),IW=1,N),JW=1,NP)
ENDIF
C -----------------------------------------------------------
c IF(MOD(NT,100).EQ.0) PRINT*,'NT EQ ',NT
50 CONTINUE
IF (OBFLAG.EQ.1.AND.NSTOP+2.EQ.NTRAJ) THEN
open (16,file='./files/obs.io',form='unformatted'
S ,status='unknown')
PRINT*,'*************************************'
PRINT*,' OBSERVATIONS ARE WRITTEN IN obs.io, NTRAJ = ',ntraj
PRINT*,'*************************************'
DO NT=1,NTRAJ
if(mod(nt,10).eq.0) write(6,*)'write obs. time ',NT
DO IKX=1,IKTX
KX = FLOAT(IKX-1)
DO IKY=1,IKTY
KY = FLOAT(IKY - KTY - 1)
KW = MAX(KX*KX+KY*KY ,0.001 )
UK(IKX,IKY)= L(IKX+KTX,IKY)*ZI*KY*ZTRAJ(IKX,IKY,NT)/KW
WK(IKX,IKY)=-L(IKX+KTX,IKY)*ZI*KX*ZTRAJ(IKX,IKY,NT)/KW
c NSK(IKX,IKY)= STRAJ(IKX,IKY,NT)
ENDDO
ENDDO
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)
c CALL KR(NSK,SR,KTX,KTY,IKTX,IKTY,N,N2,LWRK,
c . FF1,FF2,FF3,WORK,TRIGS,IFAX,ZI)
write(16) ((UR(IW,JW),IW=1,N),JW=1,N)
write(16) ((WR(IW,JW),IW=1,N),JW=1,N)
c write(16) ((SR(IW,JW),IW=1,N),JW=1,N)
ENDDO
close(16)
c++++
c ENDIF
c++++
c open (16,file='./files/bkg.io',form='unformatted')
open (16,file='cont.io',form='unformatted')
PRINT*,'*************************************'
PRINT*,' Z CONTROL IS WRITTEN IN CONT.dat'
PRINT*,'*************************************'
DO NT=1,NTRAJ
if(mod(nt,10).eq.0) write(6,*) 'Write traj. time ',NT
write(16) ((ZTRAJ(IW,JW,NT),IW=1,IKTX),JW=1,IKTY)
ENDDO
close(16)
ENDIF
if (grflag.eq.1) then
close(10)
close(11)
close(111)
close(13)
close(14)
close(15)
endif
IF (TEFLAG.EQ.1) close(18)
99 FORMAT(8E12.4)
88 FORMAT(E12.4)
RETURN
END