[Fortran] 纯文本查看 复制代码
c fortran language program oof mixed discret composite programming
integer en,p,eq,cycle,cst,fun,sch,qun
REAL X0(20),IX0(20),XL(20),IXL(20),XU(20),IXU(20),XB(20),IXB(20)
1 ,XT(20),IXT(20),DX(20),IDX(20),G(500),IV(20,41),Y(41),XV(500,20)
character*1 iyn
character*3 chr1,chr3
character*8 chr2
DIMENSION NP(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/C10/XV/C11/N1/C12/F1,F2,PF0,PF1
COMMON /CSUB/SUB/ci7/i7
WRITE(*,1300)
1300 FORMAT(/,10X,'***MDCP***',/,/,/)
write(*,5900)
5900 format(3x,'Options:',/,3x,'Checkout Adjacent Points?(Y/N)',\)
read(*,'(a)')iyn
if (iyn.eq.'y'.or.iyn.eq.'Y') then
i1=1
else
i1=0
endif
write(*,6001)
6001 format(3x,'Quadratic accelerating?(Y/N)',\)
read(*,'(a)')iyn
if (iyn.eq.'y'.or.iyn.eq.'Y') then
i2=1
else
i2=0
endif
write(*,6002)
6002 format(3x,'Change Search Direction?(Y/N)',\)
read(*,'(a)')iyn
if (iyn.eq.'y'.or.iyn.eq.'Y') then
i3=1
else
i3=0
endif
write(*,6003)
6003 format(3x,'Reconstruct Complex?(Y/N)',\)
read(*,'(a)') iyn
if (iyn.eq.'y'.or.iyn.eq.'Y') then
i4=1
else
i4=0
endif
write(*,6005)
6005 format(3x,'Search Along Bounds?(Y/N)',\)
read(*,'(a)') iyn
if (iyn.eq.'y'.or.iyn.eq.'Y') then
i5=1
else
i5=0
endif
write(*,6006)
6006 format(3x,'Show Computational Details?(Y/N)',\)
read(*,'(a)') iyn
if (iyn.eq.'y'.or.iyn.eq.'Y') then
i6=1
else
i6=0
endif
WRITE(*,1060)I1,I2,I3,I4,I5,I6
1060 FORMAT(8X,'I1',8X,'I2',8X,'I3',8X,'I4',8X,'I5',8X,'I6',/,6I10)
write(*,7001)
7001 format(3x,'data file name=****.***')
read(*,7003)chr2
7003 format(17x,a)
write(*,7005)
7005 format(3x,'a new file or an old one?(new/old)',\)
read(*,'(a3)')chr3
if(chr3.eq.'new'.or.chr3.eq.'NEW') then
open(1,file=chr2,status='new',access='direct',form='binary',
1 recl=80)
else
open(1,file=chr2,access='direct',form='binary',recl=80)
read(1,rec=1)n,m,eq,p,en,nn,mi,nv
WRITE(*,1080)N,M,EQ,P,EN,NN,MI,NV
endif
close(1)
6009 write(*,6010)
6010 format(3x,'New Problem Parameters?(Y/N)',\)
read(*,'(a)')iyn
open(1,file=chr2,access='direct',form='binary',recl=80)
if(iyn.eq.'y'.or.iyn.eq.'Y') then
write(*,6020)
6020 format(3x,'N=** M=*** EQ=** P=** EN=** NN=*** MI=*******')
read(*,6022)n,m,eq,p,en,nn,mi
6022 format(4x,i2,4x,i3,5x,i2,4x,i2,5x,i2,5x,i3,5x,i7)
NV=2*N+1
WRITE(*,1080)N,M,EQ,P,EN,NN,MI,NV
1080 FORMAT(3X,'N=',I2,2X,'M=',I3,2X,'EQ=',I2,2X,'P=',I2,2X,'EN=',I2,
1 2X,'NN=',I3,2X,'MI=',I7,2X,'NV=',I2)
write(1,rec=1)n,m,eq,p,en,nn,mi,nv
elseif(iyn.ne.'n'.and.iyn.ne.'N') then
goto 6009
else
read(1,rec=1)n,m,eq,p,en,nn,mi,nv
endif
if(chr3.eq.'new'.or.chr3.eq.'NEW') goto 6023
read(1,rec=2)x0
close(1)
write(*,'(1x,6f13.6)')(x0(i),i=1,n)
6023 write(*,6024)
6024 format(3x,'New Initial Point?(Y/N)',\)
read(*,'(a)')iyn
open(1,file=chr2,access='direct',form='binary',recl=80)
if (iyn.eq.'y'.or.iyn.eq.'Y') then
chr1='X0('
call input(chr1,x0)
write(1,rec=2)x0
elseif(iyn.ne.'n'.and.iyn.ne.'N') then
goto 6023
else
read(1,rec=2)x0
endif
if(chr3.eq.'new'.or.chr3.eq.'NEW') goto 6025
read(1,rec=3)xu
close(1)
write(*,'(1x,6f13.6)')(xu(i),i=1,n)
6025 write(*,6026)
6026 format(3x,'New Upper Bounds?(Y/N)',\)
read(*,'(a)')iyn
open(1,file=chr2,access='direct',form='binary',recl=80)
if (iyn.eq.'y'.or.iyn.eq.'Y') then
chr1='XU('
call input(chr1,xu)
write(1,rec=3)xu
elseif(iyn.ne.'n'.and.iyn.ne.'N') then
goto 6025
else
read(1,rec=3)xu
endif
if(chr3.eq.'new'.or.chr3.eq.'NEW') goto 6027
read(1,rec=4)xl
close(1)
write(*,'(1x,6f13.6)')(xl(i),i=1,n)
6027 write(*,6028)
6028 format(3x,'New Lower Bounds?(Y/N)',\)
read(*,'(a)')iyn
open(1,file=chr2,access='direct',form='binary',recl=80)
if (iyn.eq.'y'.or.iyn.eq.'Y') then
chr1='XL('
call input(chr1,xl)
write(1,rec=4)xl
elseif(iyn.ne.'n'.and.iyn.ne.'N') then
goto 6027
else
read(1,rec=4)xl
endif
if(chr3.eq.'new'.or.chr3.eq.'NEW') goto 6029
read(1,rec=5)dx
close(1)
write(*,'(1x,6f13.6)')(dx(i),i=1,n)
6029 write(*,6030)
6030 format(3x,'New Variable Increaments?(Y/N)',\)
read(*,'(a)')iyn
open(1,file=chr2,access='direct',form='binary',recl=80)
if (iyn.eq.'y'.or.iyn.eq.'Y') then
chr1='DX('
call input(chr1,dx)
write(1,rec=5)dx
elseif(iyn.ne.'n'.and.iyn.ne.'N') then
goto 6029
else
read(1,rec=5)dx
endif
close(1)
IF(EQ.EQ.0) GOTO 510
6039 write(*,6040)
6040 format(3x,'New Design Space?(Y/N)',\)
read(*,'(a)')iyn
open(1,file=chr2,access='direct',form='binary',recl=80)
if(iyn.eq.'y'.or.iyn.eq.'Y') then
call inpnp(np)
call inpxv(np)
write(1,rec=6)np
do 917 j=1,nn
irc=6+j
write(1,rec=irc)(xv(j,i),i=1,eq)
917 continue
elseif(iyn.ne.'n'.and.iyn.ne.'N') then
goto 6039
else
read(1,rec=6)np
write(*,'(1x,10i8)')(np(i),i=1,eq)
do 919 j=1,nn
irc=6+j
read(1,rec=irc)(xv(j,i),i=1,eq)
919 continue
write(*,'(1x,6f13.6)')((xv(j,i),j=1,nn),i=1,eq)
endif
close(1)
510 CONTINUE
DO 512 I=1,N
IF(X0(I).LT.XL(I).OR.X0(I).GT.XU(I)) GOTO 515
512 CONTINUE
GOTO 520
515 WRITE(*,1180)
1180 FORMAT(5X,'THE INITIAL POINT VIOLATES THE BOUNDS FOR VARIABLES')
GOTO 599
520 CONTINUE
DO 522 I=1,N
IF(I-P) 524,524,526
524 IDX(I)=1
GOTO 522
526 IDX(I)=DX(I)
522 CONTINUE
DO 550 I=1,N
IF(I.GT.EQ) GOTO 530
IXL(I)=1
IXU(I)=NP(I)
JJ=NP(I)
W=10.E10
DO 532 J=1,JJ
IF(ABS(X0(I)-XV(J,I)).GE.W) GOTO 532
K=J
W=ABS(X0(I)-XV(J,I))
532 CONTINUE
IX0(I)=K
X0(I)=XV(K,I)
GOTO 550
530 CONTINUE
IF(I.GT.P) GOTO 540
W=XL(I)/DX(I)+.5
IXL(I)=AINT(W)
W=XU(I)/DX(I)
IXU(I)=AINT(W)
W=X0(I)/DX(I)+sign(1.,x0(i))*.5
IX0(I)=AINT(W)
X0(I)=IX0(I)*DX(I)
GOTO 550
540 IXL(I)=XL(I)
IXU(I)=XU(I)
IX0(I)=X0(I)
550 CONTINUE
CYCLE=0
FUN=0
CST=0
SCH=0
QUN=0
PF0=EF(X0)
WRITE(*,1215)(X0(I),I=1,N)
1215 FORMAT(5X,'X0(I)=',8F8.3)
WRITE(*,1190)(G(I),I=1,M)
1190 FORMAT(5X,'G=',/,5F15.7)
WRITE(*,1200)PF0
1200 FORMAT(5X,'PF0=',F15.7)
CALL COMPLE
IF(FUN-1) 560,562,562
560 WRITE(*,1210)
1210 FORMAT(10X,'NO FEASIBLE POINT')
GOTO 564
562 WRITE(*,1220)
1220 FORMAT(72('E'))
564 RAT=ABS((PF0-PF1)/PF0)
WRITE(*,1230)CYCLE,SCH,QUN,FUN,CST,RAT
1230 FORMAT(5X,'CYCLE=',I3,5X,'SCH=',I5,5X,'QUN=',I4,/,5X,'FUN=',I6,
1 5X,'CST=',I6,/,5X,'RAT=',F15.7)
write(*,8001)
8001 format(3x,'Show All Constraints?(Y/N)',\)
read(*,'(a)')iyn
if(iyn.eq.'y'.or.iyn.eq.'Y') then
DO 565 I=1,M
565 WRITE(*,1240)I,G(I)
1240 FORMAT(10X,'G(',I3,')=',F15.7)
endif
write(*,8003)
8003 format(3x,'Show Solution?(Y/N)',\)
read(*,'(a)')iyn
if(iyn.eq.'y'.or.iyn.eq.'Y') then
DO566 I=1,N
566 WRITE(*,1250)I,XT(I)
1250 FORMAT(20X,'X(',I2,')=',F15.7)
WRITE(*,1260)PF1
1260 FORMAT(20X,'F(X)=',F15.7,/,/)
endif
write(*,8005)
8005 format(3x,'Show All Verticies?(Y/N)',\)
read(*,'(a)')iyn
if(iyn.eq.'y'.or.iyn.eq.'Y') then
WRITE(*,1270)(Y(I),I=1,NV)
1270 FORMAT(5X,'Y=',/,5F15.7)
PF1=FUNC(XT,FUN)
DO 570 I=1,NV
DO 568 J=1,N
568 IXT(J)=IV(J,I)
CALL ROUND(XT,IXT)
WRITE(*,1280)I,(XT(J),J=1,N)
1280 FORMAT(5X,'XV=',I2,/,1X,'X=',/,8F15.7)
CALL CONST(XT,G,CST)
WRITE(*,1290)(G(J),J=1,M)
1290 FORMAT(1X,'G=',/,5F15.7)
570 CONTINUE
endif
599 CONTINUE
STOP
END
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
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
F 币
贡献
权杖
窥视卡
发表于 2014-4-29 20:39:37
微信
收藏
点赞
点踩
提升卡
置顶卡
变色卡
千斤顶
显身卡
发表于 2014-8-1 13:09:45
楼主
发表于 2014-5-10 19:46:46