[Fortran] 纯文本查看 复制代码
subroutine comple
integer cycle,en,p,eq,cst,fun,sch,qun
character*1 iyn
character*3 chr
CHARACTER*8 NAME
real x0(20),ix0(20),xl(20),ixl(20),xu(20),ixu(20),xb(20),
1 ixb(20),xt(20),ixt(20),dx(20),idx(20),g(500),iv(20,41),y(41),
2 xv(500,20)
common /c0/i1,i2,i3,i4,i5,i6/c1/n,m,en,p,eq,nv/c2/mi,cycle,cst,
1 fun,sch,qun/c3/g/c4/x0,ix0/c5/xb,ixb/c6/xt,ixt/c7/xl,ixl,xu,ixu
2 /c8/dx,idx/c9/iv,y/c11/n1/c12/f1,f2,pf0,pf1/c10/xv
common /csub/sub/ci7/i7/cff/ff(11,2),kk,knt/c15/fo(11),df(11,2),
1 dfdx(11,4),cf(11,4)
WRITE(*,'(1x,A)')'Verticies Storage File Name=****.*** NSCH=***' 第二个文件处
READ(*,'(28X,A8,6X,I3)')NAME,NSCH
919 write(*,'(1x,a,\)')'Input Verticies?(y/n)'
READ(*,'(A)')IYN
IF(IYN.EQ.'y'.or.IYN.EQ.'Y') then
goto 913 顺便问下,这里直接转到913标号处,那下面do 300 i=1,n 是不是就没有操作 ??????
elseif(iyn.ne.'n'.and.iyn.ne.'N') then
goto 919
endif
do 300 i=1,n
300 iv(i,1)=ix0(i)
y(1)=pf0
430 continue
do 302 k=1,n
do 304 i=1,n
if (i.eq.k) go to 306
ii=k+1
iv(i,ii)=ix0(i)
ii=ii+n
iv(i,ii)=ix0(i)
go to 308
306 ii=k+1
iv(i,ii)=ixl(i)
ii=ii+n
iv(i,ii)=ixu(i)
308 continue
304 continue
302 continue
goto 440
913 OPEN(2,FILE=NAME,ACCESS='DIRECT',FORM='BINARY',RECL=160)
DO 921 I=1,NV
READ(2,REC=I)(IV(J,I),J=1,N)
921 CONTINUE
nv1=nv+1
read(2,rec=nv1)sch,fun,cst,cycle
CLOSE(2)
DO 923 I=1,N
923 IX0(I)=IV(I,1)
CALL ROUND(X0,IX0)
PF0=EF(X0)
Y(1)=PF0
write(*,'(1x,2hx0,6f13.6)')(x0(i),i=1,n)
write(*,'(1x,5hf(x0),3x,f13.6)')pf0
write(*,'(1x,4hsch=,i4,3x,4hfun=,i5,3x,4hcst=,i5,3x,6hcycle=,i2)
1 ')sch,fun,cst,cycle
440 continue
do 310 i=2,nv
do 312 j=1,n
312 ixt(j)=iv(j,i)
call round(xt,ixt)
310 y(i)=ef(xt)
450 call compar
if (i6.ne.1) go to 350
write(*,1000) (y(i),i=1,nV)
1000 format(1x,2hf=,/,5f15.7)
do 320 i=1,nv
do 315 j=1,n
315 ixt(j)=iv(j,i)
call round(xt,ixt)
write(*,1010) i,(xt(ii),ii=1,n)
1010 format(1x,2hx=,i5,/,(5f15.7))
320 continue
350 ir=0
do 352 i=1,n
dl=1.e10
du=-1.e10
do 354 j=1,nv
w=iv(i,j)
if (w.ge.du) du=w
if (w.le.dl) dl=w
354 continue
w=du-dl
if (w.le.idx(i)) ir=ir+1
352 continue
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