[Fortran] 纯文本查看 复制代码
if (ir.ge.en) go to 470
if (i2.ne.1) go to 360
w=sch/15
iw=int(w)
if (iw.le.qun) go to 360
call quadr
if (f1.ge.y(1)) go to 360
call round(xb,ixb)
write(*,1020) qun,f1,(xb(i),i=1,n)
1020 format(10x,7hsuccess,/,10x,4hqun=,i5,/,10x,2hf=,f15.7,/,
1 10x,2hx=,/,(5f15.7))
y(nv)=f1
do 356 i=1,n
356 iv(i,nv)=ixb(i)
go to 450
360 continue
IF(I7.EQ.1) THEN
isch=sch/50
if (isch*50.ne.sch) go to 351
ngl=0
do 337 i=1,n
ngt=0
nlt=0
do 331 j=2,nv
if (iv(i,j).gt.iv(i,1)) ngt=ngt+1
if (iv(i,j).lt.iv(i,1)) nlt=nlt+1
331 continue
if (ngt.gt.1.and.nlt.gt.1) ngl=ngl+1
337 continue
if (ngl.gt.1) go to 351
sub=1.
n1=nv
call search
if (f1.gE.y(n1)) go to 351
do 346 i=1,n
346 iv(i,nv)=ixb(i)
y(nv)=f1
KT=4
go to 450
351 continue
ENDIF
n1=nv
460 MSCH=SCH/NSCH
IF(MSCH*NSCH.EQ.SCH) THEN
OPEN(2,FILE=NAME,STATUS='NEW',ACCESS='DIRECT',FORM='BINARY',
1 RECL=160)
DO 927 I=1,NV
WRITE(2,REC=I)(IV(J,I),J=1,N)
927 CONTINUE
nv1=nv+1
write(2,rec=nv1)sch,fun,cst,cycle
CLOSE(2)
ENDIF
call search
if (f1.ge.y(n1)) go to 366
do 362 i=1,n
362 iv(i,nv)=ixb(i)
y(nv)=f1
KT=5
go to 450
366 continue
if (i3.ne.1) go to 380
480 n1=n1-1
if (n1.le.1) go to 380
iw=0
ii=n1+1
do 370 i=1,n
if (iv(i,n1).eq.iv(i,ii)) go to 370
iw=1
go to 490
370 continue
490 continue
if (iw.eq.1) go to 460
go to 480
380 continue
do 382 i=2,nv
do 384 j=1,n
w=iv(j,1)+0.667*(iv(j,i)-iv(j,1))
if (j.gt.p) go to 384
w=w+0.5
w=int(w)
384 iv(j,i)=w
382 continue
go to 440
470 continue
if (i1.ne.1) go to 500
do 386 i=2,nv
w=1.0
do 388 j=1,n
ii=i-1
if (iv(j,ii).ne.iv(j,i)) w=0.
388 continue
if (w.eq.1.) go to 386
do 390 j=1,n
ixt(j)=2*iv(j,1)-iv(j,i)
if (ixt(j).gt.ixu(j)) ixt(j)=ixu(j)
if (ixt(j).lt.ixl(j)) ixt(j)=ixl(j)
390 continue
call round(xt,ixt)
w=ef(xt)
if (w.ge.y(1)) go to 386
y(i)=w
do 392 j=1,n
392 iv(j,i)=ixt(j)
go to 450
386 continue
500 cycle=cycle+1
do 394 i=1,n
394 ixt(i)=iv(i,1)
call round(xt,ixt)
pf1=y(1)
write(*,1030) cycle,sch,fun,cst,pf1
1030 format(5x,'cycle=',i5,5x,'sch=',i5,5x,'fun=',i5,5x,'cst=',i5,/,
1 10x,'pf1=',f15.7,/)
write(*,1301) (xt(i),i=1,n)
1301 format(1x,2hx=,5f15.7)
if (i4.ne.1) go to 400
do 408 i=1,n
if (abs(iv(i,1)-ix0(i)).le.1e-6) go to 408
do 402 j=1,n
402 ix0(j)=iv(j,1)
go to 430
408 continue
400 call const(xt,g,cst)
return
end
subroutine search
real xt(20),ixt(20),xb(20),ixb(20),dx(20),idx(20),y(41),
1 iv(20,41),xu(20),ixu(20),xl(20),ixl(20),s(20),g(500),xv(500,20)
integer en,p,eq,cycle,cst,fun,qun,sch
common /c1/n,m,en,p,eq,nv/c2/mi,cycle,cst,fun,sch,qun
1 /c5/xb,ixb/c6/xt,ixt/c7/xl,ixl,xu,ixu/c8/dx,idx/c9/iv,y
2 /c11/n1/c0/i1,i2,i3,i4,i5,i6/c12/f1,f2,pf0,pf1/c3/g/c10/xv
common /csub/sub
do 40 i=1,n
40 ixb(i)=iv(i,n1)
f1=y(n1)
do 41 i=1,n
w=0.
if(sub.ne.1.) goto 777
w=iv(i,1)
goto 779
777 continue
do 42 j=1,nv
42 if(j.ne.n1) w=w+iv(i,j)
w=w/(nv-1)
779 continue
41 s(i)=w-ixb(i)
w=10.e10
him=10.e10
do 43 i=1,n
if(abs(s(i)).gt.10.e-8) w=abs(idx(i)/s(i)/2)
if(w.lt.him) him=w
43 continue
t=1.3
t0=1.3
r=1.
110 continue
if(t.lt.him) goto 120
do 44 i=1,n
w=iv(i,n1)+t0*s(i)
if(i.le.p) w=aint(w+.5)
ixt(i)=w
if(i5.ne.1) goto 46
if(ixt(i).gt.ixu(i)) ixt(i)=ixu(i)
if(ixt(i).lt.ixl(i)) ixt(i)=ixl(i)
goto 44
46 continue
if(ixt(i).le.ixu(i).and.ixt(i).ge.ixl(i)) goto 44
t=t/2
r=-1.
t0=t0-t
goto 110
44 continue
call round(xt,ixt)
f2=ef(xt)
if(f2.lt.f1) goto 50
t=t/2
r=-1.
t0=t0-t
goto 110
50 continue
do 51 i=1,n
xb(i)=xt(i)
51 ixb(i)=ixt(i)
f1=f2
if(r.eq.1.) t=t*2
if(r.ne.1.) t=t/2
t0=t0+t
goto 110
120 sch=sch+1
return
end
subroutine quadr
integer en,p,eq,cycle,cst,fun,sch,qun
real a(20),b(20),c(20),e(20),f(20),h(20),xb(20),ixb(20),
1 iv(20,41),xt(20),ixt(20),xu(20),ixu(20),xl(20),ixl(20),dx(20),
2 idx(20),y(41),g(500),xv(500,20)
common /c1/n,m,en,p,eq,nv/c2/mi,cycle,cst,fun,sch,qun/c5/xb,ixb
1 /c6/xt,ixt/c7/xl,ixl,xu,ixu/c8/dx,idx/c9/iv,y/c12/f1,f2,pf0,pf1
2 /c3/g/c10/xv
do 60 i=1,n
ixb(i)=iv(i,1)
60 c(i)=ixb(i)
f1=y(1)
do 62 i=2,nv
k=i
do 64 j=1,n
if(abs(iv(j,i)-c(j)).gt.10.e-4) goto 210
64 continue
62 continue
goto 250
210 continue
do 66 i=1,n
66 b(i)=iv(i,k)
kk=k+1
do 68 i=kk,nv
k=i
do 70 j=1,n
if(abs(iv(j,i)-b(j)).gt.10.e-4) goto 220
70 continue
68 continue
goto 250
220 continue
do 72 i=1,n
72 a(i)=iv(i,k)
ii=1
do 74 i=1,n
k=i
if(a(i).lt.b(i).and.b(i).lt.c(i)) goto 230
74 continue
ii=-1
do 76 i=1,n
k=i
if(a(i).gt.b(i).and.b(i).gt.c(i)) goto 230
76 continue
ii=0
230 continue
if(ii.eq.0) goto 250
do 78 i=1,n
e(i)=c(i)
f(i)=(b(i)-c(i))/(b(k)-c(k))
78 h(i)=((a(i)-c(i))/(a(k)-c(k))-f(i))/(a(k)-b(k))
d1=ii*2*idx(k)
d=d1
w=1.
240 continue
if(abs(d).lt.idx(k)/2) goto 250
do 80 i=1,n
ixt(i)=e(i)+f(i)*d1+h(i)*d1*(d1+c(k)-b(k))
wi=ixt(i)+.5
if(i.le.p) ixt(i)=aint(wi)
if(ixt(i).le.ixu(i).and.ixt(i).ge.ixl(i)) goto 82
w=-1
d=d/2
d1=d1-d
goto 240
82 continue
80 continue
call round(xt,ixt)
f2=ef(xt)
if(f2.lt.f1) goto 83
w=-1
d=d/2
d1=d1-d
goto 240
83 f1=f2
do 84 i=1,n
ixb(i)=ixt(i)
84 xb(i)=xt(i)
if(w.eq.1) d=d*2
if(w.ne.1) d=d/2
d1=d1+d
goto 240
250 qun=qun+1
return
end
subroutine input(chr1,x)
character*1 iyn
character*3 chr1
character*13 chr2
dimension x(20)
common /c1/n,m,en,p,eq,nv
chr2=')=*****.*****'
do 10 i=1,n
write(*,100)chr1,i,chr2
100 format(3x,a3,i2,a13)
read(*,200)x(i)
200 format(9x,f11.5)
write(*,200)x(i)
10 continue
14 write(*,300)
300 format(3x,'all right?(y/n)',\)
read(*,'(a)')iyn
if(iyn.eq.'n'.or.iyn.eq.'N') then
write(*,400)chr1,chr2
400 format(3x,'i=** ',3x,a3,'i',a13)
read(*,500)i,x(i)
500 format(4x,i2,6x,f11.5)
write(*,500)i,x(i)
goto 14
elseif(iyn.ne.'y'.and.iyn.ne.'Y') then
goto 14
endif
return
end
subroutine inpnp(np)
integer eq
character*1 iyn
character*3 chr1
character*6 chr2
dimension np(20)
common /c1/n,m,en,p,eq,nv
chr1='Np('
chr2=')=****'
do 10 i=1,eq
write(*,100)chr1,i,chr2
100 format(3x,a3,i2,a6)
read(*,200)np(i)
200 format(9x,i4)
write(*,200)np(i)
10 continue
14 write(*,300)
300 format(3x,'all right?(y/n)',\)
read(*,'(a)')iyn
if(iyn.eq.'n'.or.iyn.eq.'N') then
write(*,400)chr1,chr2
400 format(3x,'i=** ',3x,a3,'i',a13)
read(*,500)i,np(i)
500 format(4x,i2,6x,i4)
write(*,500)i,np(i)
goto 14
elseif(iyn.ne.'y'.and.iyn.ne.'Y') then
goto 14
endif
return
end
subroutine inpxv(np)
integer eq
character*1 iyn
character*3 chr1
character*13 chr2
dimension np(20),xv(500,20)
common /c1/n,m,en,p,eq,nv/c10/xv
chr1='XV('
chr2=')=*****.*****'
do 10 i=1,eq
do 10 j=1,np(i)
write(*,100)chr1,j,i,chr2
100 format(3x,a3,i3,',',i2,a13)
read(*,200)xv(j,i)
200 format(13x,f11.5)
write(*,200)xv(j,i)
10 continue
299 write(*,300)
300 format(3x,'all right?(y/n)',\)
read(*,'(a)')iyn
if(iyn.eq.'n'.or.iyn.eq.'N') then
write(*,400)chr1,chr2
400 format(3x,'j=*** i=**',2x,a3,'j,i',a13)
read(*,500)j,i,xv(j,i)
500 format(4x,i3,4x,i2,9x,f11.5)
write(*,500)j,i,xv(j,i)
goto 299
elseif(iyn.ne.'y'.and.iyn.ne.'Y') then
goto 299
endif
return
end
subroutine compar
real y(41),iv(20,41)
common /c1/n,m,en,p,eq,nv/c9/iv,y
jj=nv-1
do 30 i=1,jj
j=i
ii=i+1
do 31 k=ii,nv
if(y(k).lt.y(j)) j=k
31 continue
w=y(i)
y(i)=y(j)
y(j)=w
do 32 k=1,n
w=iv(k,i)
iv(k,i)=iv(k,j)
32 iv(k,j)=w
30 continue
return
end
subroutine round(x,ix)
real x(20),ix(20),dx(20),xv(500,20),idx(20)
integer en,p,eq
common /c1/n,m,en,p,eq,nv/c8/dx,idx/c10/xv
do 20 i=1,n
w=ix(i)+0.5
ii=int(w)
if (i.le.eq) x(i)=xv(ii,i)
if (i.gt.eq.and.i.le.p) x(i)=dx(i)*ix(i)
if (i.gt.p) x(i)=ix(i)
20 continue
return
end
FUNCTION EF(X)
DIMENSION X(20),G(500)
INTEGER CST,FUN,SCH,QUN
COMMON /C1/N,M,EN,P,EQ,NV/C3/G/C2/MI,CYCLE,CST,FUN,SCH,QUN
CALL CONST(X,G,CST)
SUM=0.
DO 10 I=1,M
IF(G(I).GT.0) SUM=SUM+G(I)
10 CONTINUE
IF(SUM.EQ.0) GOTO 11
W=MI+SUM
GOTO 12
11 W=FUNC(X,FUN)
12 EF=W
RETURN
END
FUNCTION FUNC(X,FUN)
DIMENSION X(20)
INTEGER FUN
FUN=FUN+1
FUNC=X(1)+120*X(2)
RETURN
END
SUBROUTINE CONST(X,G,CST)
DIMENSION X(20),G(500)
INTEGER CST
G(1)=4-X(1)
G(2)=6.429+X(1)*X(2)
G(3)=6.429-X(1)*X(2)**3
G(4)=321.14-X(1)**2*X(2)
CST=CST+1
RETURN
END 
F 币
贡献
权杖
窥视卡
发表于 2014-4-29 22:20:32
显身卡
楼主