马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。
您需要 登录 才可以下载或查看，没有账号？我要加入
x
!C *********************************************************
!C * fixed-fixed *
!C *********************************************************
PARAMETER (NVAR=8,N2=3,DELTA=0.1E-1,EPS=0.1E-3)
DIMENSION V(3),DELV(3),F(3),DV(3),YS(8)
COMMON HL,Wmax,T
OPEN(1,FILE='xb1.DAT')
OPEN(2,FILE='xb2.DAT')
OPEN(3,FILE='xb3.DAT')
OPEN(4,FILE='xb4.DAT')
OPEN(5,FILE='xb5.DAT')
!WRITE(*,*) ' V(1),V(2),V(3)='
!READ(*,*) V(1),V(2),V(3)
V(1)=0.1
V(2)=0.2
V(3)=1.0
HL=40.0
T=50.0
X1=0.5
H1=0.1
HMIN=1.0E-30
X2=1.0
DO 10 J=10,150,1
W=J/100.0
Wmax=W/HL
DELV(1)=DELTA*V(1)
DELV(2)=DELTA*V(2)
DELV(3)=DELTA*V(3)
9 CALL SHOOT(NVAR,YS,V,DELV,N2,X1,X2,EPS,H1,HMIN,F,DV)
WRITE(*,*) W,V(1),V(2),v(3)
IF(ABS(DV(1)).GT.ABS(EPS*V(1)).OR.ABS(DV(2)).GT.ABS(EPS*V(2)).OR.ABS(DV(3)).GT.ABS(EPS*V(3))) GOTO 9
WRITE(1,*) W,V(1),V(2),v(3)
WRITE(2,*) V(3),W
WRITE(3,*) v(3),v(1)
WRITE(5,*) v(3),V(2)
10 CONTINUE
END
SUBROUTINE LOAD(X1,V,Y)
DIMENSION V(3),Y(8)
COMMON HL,Wmax,T
Y(1)=0.0
Y(2)=0.0
Y(3)=Wmax
Y(4)=0.0
Y(5)=V(1)
Y(6)=V(2)
Y(7)=0.0
Y(8)=V(3)
RETURN
END
SUBROUTINE SCORE(X2,Y,F)
DIMENSION Y(8),F(3)
COMMON HL,Wmax,T
F(1)=Y(2)
F(2)=Y(3)
F(3)=Y(4)
RETURN
END
!C
SUBROUTINE DERIVS(X,Y,DYDX)
DIMENSION Y(8),DYDX(8)
COMMON HL,Wmax,T
R=(T-Y(6)*COS(Y(4))-Y(7)*SIN(Y(4)))/(12.0*HL**2)+1.0
DYDX(1)=R
DYDX(2)=R*COS(Y(4))-1.0
DYDX(3)=R*SIN(Y(4))
DYDX(4)=Y(5)
DYDX(5)=R*(-Y(6)*sin(Y(4))+Y(7)*cos(Y(4)))
DYDX(6)=0.0
DYDX(7)=R*Y(8)
DYDX(8)=0.0
RETURN
END
SUBROUTINE SHOOT(NVAR,YS,V,DELV,N2,X1,X2,EPS,H1,HMIN,F,DV)
EXTERNAL DERIVS,RKQC
PARAMETER (NP=20)
DIMENSION V(N2),DELV(N2),F(N2),DV(N2),Y(NP),DFDV(NP,NP),INDX(NP),YS(NVAR)
CALL LOAD(X1,V,Y)
CALL ODEINT(Y,NVAR,X1,X2,EPS,H1,HMIN,NOK,NBAD,DERIVS,RKQC)
CALL SCORE(X2,Y,F)
DO 12 IV=1,N2
SAV=V(IV)
V(IV)=V(IV)+DELV(IV)
CALL LOAD(X1,V,Y)
CALL ODEINT(Y,NVAR,X1,X2,EPS,H1,HMIN,NOK,NBAD,DERIVS,RKQC)
DO 222 J=1,NVAR
222 YS(J)=Y(J)
CALL SCORE(X2,Y,DV)
DO 11 I=1,N2
DFDV(I,IV)=(DV(I)-F(I))/DELV(IV)
11 CONTINUE
V(IV)=SAV
12 CONTINUE
DO 13 IV=1,N2
DV(IV)=-F(IV)
13 CONTINUE
CALL LUDCMP(DFDV,N2,NP,INDX,DET)
CALL LUBKSB(DFDV,N2,NP,INDX,DV)
DO 14 IV=1,N2
V(IV)=V(IV)+DV(IV)
14 CONTINUE
RETURN
END
SUBROUTINE ODEINT(YSTART,NVAR,X1,X2,EPS,H1,HMIN,NOK,NBAD,DERIVS,RKQC)
PARAMETER (MAXSTP=10000,NMAX=20,TWO=2.0,ZERO=0.0,TINY=1.E-30)
COMMON /PATH/KMAX,KOUNT,DXSAV,XP(350),YP(15,350)
DIMENSION YSTART(NVAR),YSCAL(NMAX),Y(NMAX),DYDX(NMAX)
X=X1
H=SIGN(H1,X2-X1)
NOK=0
NBAD=0
KOUNT=0
DO 11 I=1,NVAR
Y(I)=YSTART(I)
11 CONTINUE
XSAV=X-DXSAV*TWO
DO 16 NSTP=1,MAXSTP
CALL DERIVS(X,Y,DYDX)
DO 12 I=1,NVAR
YSCAL(I)=ABS(Y(I))+ABS(H*DYDX(I))+TINY
12 CONTINUE
IF (KMAX.GT.0) THEN
IF (ABS(X-XSAV).GT.ABS(DXSAV)) THEN
IF (KOUNT.LT.KMAX-1) THEN
KOUNT=KOUNT+1
XP(KOUNT)=X
DO 13 I=1,NVAR
YP(I,KOUNT)=Y(I)
13 CONTINUE
XSAV=X
ENDIF
ENDIF
ENDIF
IF ((X+H-X2)*(X+H-X1).GT.ZERO) H=X2-X
CALL RKQC(Y,DYDX,NVAR,X,H,EPS,YSCAL,HDID,HNEXT,DERIVS)
IF (HDID.EQ.H) THEN
NOK=NOK+1
ELSE
NBAD=NBAD+1
ENDIF
IF ((X-X2)*(X2-X1).GE.ZERO) THEN
DO 14 I=1,NVAR
YSTART(I)=Y(I)
14 CONTINUE
IF (KMAX.NE.0) THEN
KOUNT=KOUNT+1
XP(KOUNT)=X
DO 15 I=1,NVAR
YP(I,KOUNT)=Y(I)
IF(I.GT.1) GO TO 15
15 CONTINUE
ENDIF
RETURN
ENDIF
IF (ABS(HNEXT).LT.HMIN) PAUSE 'Stepsize smaller then minimun.'
H=HNEXT
16 CONTINUE
PAUSE'Too many steps.'
RETURN
END
SUBROUTINE RKQC(Y,DYDX,N,X,HTRY,EPS,YSCAL,HDID,HNEXT,DERIVS)
PARAMETER (NMAX=20,ONE=1.,SAFETY=0.9,ERRCON=6.E-4, FCOR=6.6667E-2)
EXTERNAL DERIVS
DIMENSION Y(N),DYDX(N),YSCAL(N),YTEMP(NMAX),YSAV(NMAX),DYSAV(NMAX)
PGROW=-0.20
PSHRNK=-0.25
XSAV=X
DO 11 I=1,N
YSAV(I)=Y(I)
DYSAV(I)=DYDX(I)
11 CONTINUE
H=HTRY
1 HH=0.5*H
CALL RK4(YSAV,DYSAV,N,XSAV,HH,YTEMP,DERIVS)
X=XSAV+HH
CALL DERIVS(X,YTEMP,DYDX)
CALL RK4(YTEMP,DYDX,N,X,HH,Y,DERIVS)
X=XSAV+H
IF (X.EQ.XSAV) PAUSE 'Stepsize not significant in RKQC.'
CALL RK4(YSAV,DYSAV,N,XSAV,H,YTEMP,DERIVS)
ERRMAX=0.
DO 12 I=1,N
YTEMP(I)=Y(I)-YTEMP(I)
ERRMAX=MAX(ERRMAX,ABS(YTEMP(I)/YSCAL(I)))
12 CONTINUE
ERRMAX=ERRMAX/EPS
IF (ERRMAX.GT.ONE) THEN
H=SAFETY*H*(ERRMAX**PSHRNK)
GOTO 1
ELSE
HDID=H
IF (ERRMAX.GT.ERRCON) THEN
HNEXT=SAFETY*H*(ERRMAX**PGROW)
ELSE
HNEXT=4.*H
ENDIF
ENDIF
DO 13 I=1,N
Y(I)=Y(I)+YTEMP(I)*FCOR
13 CONTINUE
!write(4,*) X,y(1)
!write(5,*) 1-X,y(1)
RETURN
END
SUBROUTINE RK4(Y,DYDX,N,X,H,YOUT,DERIVS)
PARAMETER (NMAX=20)
DIMENSION Y(N),DYDX(N),YOUT(N),YT(NMAX),DYT(NMAX),DYM(NMAX)
HH=H*0.5
H6=H/6.
XH=X+HH
DO 11 I=1,N
YT(I)=Y(I)+HH*DYDX(I)
11 CONTINUE
CALL DERIVS(XH,YT,DYT)
DO 12 I=1,N
YT(I)=Y(I)+HH*DYT(I)
12 CONTINUE
CALL DERIVS(XH,YT,DYM)
DO 13 I=1,N
YT(I)=Y(I)+H*DYM(I)
DYM(I)=DYT(I)+DYM(I)
13 CONTINUE
CALL DERIVS(X+H,YT,DYT)
DO 14 I=1,N
YOUT(I)=Y(I)+H6*(DYDX(I)+DYT(I)+2.*DYM(I))
14 CONTINUE
RETURN
END
SUBROUTINE LUBKSB(A,N,NP,INDX,B)
DIMENSION A(NP,NP),INDX(N),B(N)
II=0
DO 12 I=1,N
LL=INDX(I)
SUM=B(LL)
B(LL)=B(I)
IF (II.NE.0) THEN
DO 11 J=II,I-1
SUM=SUM-A(I,J)*B(J)
11 CONTINUE
ELSE IF (SUM.NE.0.) THEN
II=I
ENDIF
B(I)=SUM
12 CONTINUE
DO 14 I=N,1,-1
SUM=B(I)
IF (I.LT.N) THEN
DO 13 J=I+1,N
SUM=SUM-A(I,J)*B(J)
13 CONTINUE
ENDIF
B(I)=SUM/A(I,I)
14 CONTINUE
RETURN
END
SUBROUTINE LUDCMP(A,N,NP,INDX,D)
PARAMETER (NMAX=100,TINY=1.0E-20)
DIMENSION A(NP,NP),INDX(N),VV(NMAX)
D=1.
DO 12 I=1,N
AAMAX=0.
DO 11 J=1,N
IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
11 CONTINUE
IF (AAMAX.EQ.0.) PAUSE'Singular matrix.'
VV(I)=1./AAMAX
12 CONTINUE
DO 19 J=1,N
IF (J.GT.1) THEN
DO 14 I=1,J-1
SUM=A(I,J)
IF (I.GT.1) THEN
DO 13 K=1,I-1
SUM=SUM-A(I,K)*A(K,J)
13 CONTINUE
A(I,J)=SUM
ENDIF
14 CONTINUE
ENDIF
AAMAX=0.
DO 16 I=J,N
SUM=A(I,J)
IF (J.GT.1) THEN
DO 15 K=1,J-1
SUM=SUM-A(I,K)*A(K,J)
15 CONTINUE
A(I,J)=SUM
ENDIF
DUM=VV(I)*ABS(SUM)
IF (DUM.GE.AAMAX) THEN
IMAX=I
AAMAX=DUM
ENDIF
16 CONTINUE
IF (J.NE.IMAX) THEN
DO 17 K=1,N
DUM=A(IMAX,K)
A(IMAX,K)=A(J,K)
A(J,K)=DUM
17 CONTINUE
D=-D
VV(IMAX)=VV(J)
ENDIF
INDX(J)=IMAX
IF (J.NE.N) THEN
IF (A(J,J).EQ.0.) A(J,J)=TINY
DUM=1./A(J,J)
DO 18 I=J+1,N
A(I,J)=A(I,J)*DUM
18 CONTINUE
ENDIF
19 CONTINUE
IF (A(N,N).EQ.0.) A(N,N)=TINY
RETURN
END |
发表于 2006-11-21 10:27
提升卡
变色卡
显身卡
楼主
发表于 2009-3-23 11:39
