裝配圖復合形法減速器優(yōu)化設計(1)

裝配圖復合形法減速器優(yōu)化設計(1),裝配,復合,減速器,優(yōu)化,設計 單級圓柱齒輪減速器復合形法fortran優(yōu)化源程序 C ============== PROGRAM COMPLE C ============== DIMENSION X(25),GX(50),XCOM(1250) COMMON /ONE/ ITE,IXE,ILI,NPE,NFX,NGR READ(*,*) N,KG,K WRITE(*,10001) N,KG,K 10001 FORMAT(25X,'========== PRIMARY DATA =========='//5X, 1 'N=',I4,5X,'KG=',I4,5X,'K=',I4) CALL MAISUB(N,K,KG,X,GX,XCOM) STOP END C =================================== SUBROUTINE MAISUB(N,K,KG,X,GX,XCOM) C =================================== DIMENSION X(N),GX(KG),XCOM(N,K),FXK(50),XR(25) DIMENSION XO(25),XH(25),XL(25),BL(25),BU(25) COMMON /ONE/ ITE,IXE,ILI,NPE,NFX,NGR COMMON /TWO/ ISE READ(*,*) (X(I),I=1,N) READ(*,*) EPS READ(*,*) KWR,ISE READ(*,*) (BL(I),I=1,N),(BU(I),I=1,N) WRITE(*,1010) (BL(I),I=1,N) WRITE(*,1015) (BU(I),I=1,N) WRITE(*,1020) EPS 1010 FORMAT(' BL:'/(5X,5E15.6)) 1015 FORMAT(' BU:'/(5X,5E15.6)) 1020 FORMAT(5X,'EPS=',E10.2) ITE=0 NFX=0 IXE=0 RM=2657863.0 1025 CALL PRICOM(N,K,KG,X,GX,XCOM,FXK,BL,BU,RM) IF(KWR.LT.0) GOTO 1041 WRITE(*,1030) 1030 FORMAT(/25X,'========== PRIMARY COMPLEX =========='/) WRITE(*,1080) K DO 1031 L=1,K WRITE(*,1085) L,(XCOM(I,L),I=1,N) 1031 CONTINUE WRITE(*,1035) (FXK(I),I=1,K) 1035 FORMAT(4X,'FXK:'/(5X,5E15.6)) 1041 WRITE(*,1042) 1042 FORMAT(/25X,'========== ITEATION COMPUTE =========='/) 1045 ITE=ITE+1 CALL FXSEGU(N,K,XCOM,FXK) DO 1050 I=1,N 1050 XL(I)=XCOM(I,K) FXL=FXK(K) SDX=0.0 DO 1055 I=1,K-1 1055 SDX=SDX+(FXL-FXK(I))**2 =SQRT(SDX/FLOAT(K-1)) IF(SDX.LE.EPS) GOTO 1210 IF(KWR.GT.0) GOTO 1056 IF(ITE/10*10.NE.ITE) GOTO 1090 1056 WRITE(*,1060) ITE,FXL IF(KWR.LT.0) GOTO 1090 WRITE(*,1065) (XL(I),I=1,N) WRITE(*,1070) FXL WRITE(*,1075) (GX(I),I=1,KG) WRITE(*,1035) (FXK(I),I=1,K) 1060 FORMAT(/1X,'***** ITE=',I4,5X,'FXL=',E15.7) 1065 FORMAT(' X :'/(5X,5E15.6)) 1070 FORMAT(' FX:'/(5X,5E15.6)) 1075 FORMAT(' GX:'/(5X,5E15.6)) 1080 FORMAT(' XCOM: (K=',I3,')') 1085 FORMAT(2X,I2/(5X,5E15.6)) 1090 LH=1 1095 DO 1100 I=1,N 1100 XH(I)=XCOM(I,LH) FXH=FXK(LH) CALL XCENTE(N,K,K,LH,XO,XCOM) CALL FFX(N,XO,FXO) CALL GGX(N,KG,XO,GX) DO 1105 J=1,KG IF(GX(J).GE.0.0) GOTO 1170 1105 CONTINUE 1140 PHI=1.3 1145 DO 1150 I=1,N 1150 XR(I)=XO(I)+PHI*(XO(I)-XH(I)) CALL FFX(N,XR,FXR) CALL GGX(N,KG,XR,GX) DO 1151 J=1,KG IF(GX(J).GE.0.0) GOTO 1152 1151 CONTINUE GOTO 1155 1152 PHI=0.5*PHI GOTO 1145 1155 IF(FXR.LT.FXH) GOTO 1160 IF(PHI.LE.1E-10) GOTO 1195 PHI=0.5*PHI GOTO 1145 1160 DO 1165 I=1,N 1165 XCOM(I,LH)=XR(I) FXK(LH)=FXR GOTO 1045 1170 DO 1175 I=1,N BL(I)=XL(I) BU(I)=XO(I) 1175 CONTINUE DO 1180 I=1,N 1180 X(I)=XL(I) ISE=1 GOTO 1025 1195 LH=LH+1 WRITE(*,1200) LH 1200 FORMAT(1X,'****** LH=',I2,'*****') IF(LH.LE.K/2) GOTO 1095 WRITE(*,1205) 1205 FORMAT(/25X,'********** ITERTION ABORTIVE **********'/) GOTO 1220 1210 WRITE(*,1215) 1215 FORMAT(/25X,'========== OPTIMUM SOLUTION =========='/) 1220 WRITE(*,1225) ITE,NFX,IXE 1225 FORMAT(' ITE=',I5,' NFX=',I5' IXE=',I5) WRITE(*,1065) (XL(I),I=1,N) WRITE(*,1070) FXL WRITE(*,1075) (GX(I),I=1,KG) RETURN END C ================================================ SUBROUTINE PRICOM(N,K,KG,X,GX,XCOM,FXK,BL,BU,RM) C ================================================ DIMENSION X(N),XO(25),BL(N),BU(N),GX(KG),XCOM(N,K),FXK(K) COMMON /TWO/ ISE 2020 IF(ISE) 2025,2050,2075 2025 WRITE(*,2019) 2019 FORMAT(5X,'READ XCOM (FORMAT: * )') READ(*,*) ((XCOM(I,J),I=1,N),J=1,K) DO 2045 L=1,K DO 2030 I=1,N 2030 X(I)=XCOM(I,L) CALL FFX(N,X,FXK(L)) CALL GGX(N,KG,X,GX) DO 2031 J=1,KG IF(GX(J).GE.0.0) GOTO 2075 2031 CONTINUE 2045 CONTINUE RETURN 2050 CALL FFX(N,X,FXK(1)) CALL GGX(N,KG,X,GX) DO 2051 L=1,KG IF(GX(L).GE.0.0) GOTO 2075 2051 CONTINUE GOTO 2095 2075 DO 2080 I=1,N CALL RANDOM(RM,Q) 2080 X(I)=BL(I)+Q*(BU(I)-BL(I)) CALL FFX(N,X,FXK(1)) CALL GGX(N,KG,X,GX) DO 2081 L=1,KG IF(GX(L).GE.0.0) GOTO 2075 2081 CONTINUE 2095 DO 2100 I=1,N 2100 XCOM(I,1)=X(I) DO 2110 L=2,K DO 2105 I=1,N CALL RANDOM(RM,Q) XCOM(I,L)=BL(I)+Q*(BU(I)-BL(I)) 2105 CONTINUE 2110 CONTINUE LH=0 DO 2155 LL=1,K-1 LL2=LL CALL XCENTE(N,K,LL2,LH,XO,XCOM) CALL FFX(N,XO,FXO) CALL GGX(N,KG,X,GX) DO 2111 L=1,KG IF(GX(L).GE.0.0) GOTO 2075 2111 CONTINUE 2115 CONTINUE LL1=LL+1 DO 2120 I=1,N 2120 X(I)=XCOM(I,LL1) 2125 CALL FFX(N,X,FXK(LL1)) CALL GGX(N,KG,X,GX) DO 2126 L=1,KG IF(GX(L).GE.0.0) GOTO 2145 2126 CONTINUE DO 2140 I=1,N 2140 XCOM(I,LL1)=X(I) GOTO 2155 2145 DO 2150 I=1,N 2150 X(I)=XO(I)+0.5*(X(I)-XO(I)) GOTO 2125 2155 CONTINUE RETURN END C =============================== SUBROUTINE FXSEGU(N,K,XCOM,FXK) C =============================== DIMENSION X(25),XCOM(N,K),FXK(K) DO 3010 L=1,K-1 KL=K-L DO 3005 LP=1,KL LP1=LP+1 IF(FXK(LP).GT.FXK(LP1)) GOTO 3005 W=FXK(LP) FXK(LP)=FXK(LP1) FXK(LP1)=W DO 3000 I=1,N X(I)=XCOM(I,LP) XCOM(I,LP)=XCOM(I,LP1) 3000 XCOM(I,LP1)=X(I) 3005 CONTINUE 3010 CONTINUE RETURN END C ==================================== SUBROUTINE XCENTE(N,K,LL,LH,XO,XCOM) C ==================================== DIMENSION XO(N),XCOM(N,K) COMMON /ONE/ ITE,IXE,ILI,NPE,NFX,NGR IXE=IXE+1 DO 4015 I=1,N XS=0.0 DO 4000 L=1,LL IF(L.EQ.LH) GOTO 4000 XS=XS+XCOM(I,L) 4000 CONTINUE IF(LH) 4010,4010,4005 4005 XO(I)=XS/FLOAT(LL-1) GOTO 4015 4010 XO(I)=XS/FLOAT(LL) 4015 CONTINUE RETURN END SUBROUTINE RANDOM(RM,Q) C ======================= C ======================= RM35=2.0**35 RM36=2.0*RM35 RM37=2.0*RM36 RM =5.0*RM IF(RM.GE.RM37) RM=RM-RM37 IF(RM.GE.RM36) RM=RM-RM36 IF(RM.GE.RM35) RM=RM-RM35 Q=RM/RM35 RETURN END