版塊導(dǎo)航: 正在加載中...

應(yīng)《網(wǎng)絡(luò)安全法》要求，自2017年10月1日起，未進(jìn)行實(shí)名認(rèn)證將不得使用互聯(lián)網(wǎng)跟帖服務(wù)。為保障您的帳號(hào)能夠正常使用，請(qǐng)盡快對(duì)帳號(hào)進(jìn)行手機(jī)號(hào)驗(yàn)證，感謝您的理解與支持！

24小時(shí)熱門版塊排行榜

北京石油化工學(xué)院2026年研究生招生接收調(diào)劑公告

返回列表

當(dāng)前只顯示滿足指定條件的回帖，點(diǎn)擊這里查看本話題的所有回帖

黑曼巴1991

版主

應(yīng)助: 4 (幼兒園)
金幣: 7421.6
散金: 335
紅花: 2
帖子: 938
在線: 292.5小時(shí)
蟲(chóng)號(hào): 2552663
注冊(cè): 2013-07-18
專業(yè): 傳動(dòng)機(jī)械學(xué)

[求助] fortran編程過(guò)程出錯(cuò)了麻煩給解決一下謝謝！！

程序運(yùn)行過(guò)程出錯(cuò)了不知道怎么辦麻煩高手給看看。。我用的是FTN95編譯器打開(kāi).f90的文件的~~ （復(fù)件也有程序）
PROGRAM POINTEHL
DIMENSION THETA(15),EALFA(15),EBETA(15)
COMMON /COM1/ENDA,A1,A2,A3,Z,HM0
COMMON /COMEK/EK,EAL,EBE
DATA N,PAI,Z,EAL,EBE,E1,EDA0,RX,RY,X0,XE,W0,US/65,3.14159265,0.68,1.0,1.0,2.21E11,0.0283,0.05,0.05,-2.5,1.5,39.24,1.5/
DATA THETA/10.,20.,30.,35.,40.,45.,50.,55.,60.,65.,70.,75.,80.,85.,90./
DATA EALFA/6.612,3.778,2.731,2.397,2.136,1.926,1.754,1.611,1.486,1.378,1.284,1.202,1.128,1.061,1.0/
DATA EBETA/0.319,0.408,0.493,0.53,0.567,0.604,0.641,0.678,0.717,0.759,0.802,0.846,0.893,0.944,1.0/
EK=RX/RY
AA=0.5*(1./RX+1./RY)
BB=0.5*ABS(1./RX-1./RY)
CC=ACOS(BB/AA)*180.0/PAI
DO I=1,15
IF(CC.LT.THETA(I))THEN
WRITE(*,*)I
EAL=EALFA(I-1)+(CC-THETA(I))*(EALFA(I)-EALFA(I-1))/(THETA(I)-THETA(I-1))
EBE=EBETA(I-1)+(CC-THETA(I))*(EBETA(I)-EBETA(I-1))/(THETA(I)-THETA(I-1))
GOTO 1
ENDIF
ENDDO
1 EA=EAL*(1.5*W0/AA/E1)**(1./3.0)
EB=EBE*(1.5*W0/AA/E1)**(1./3.0)
PH=1.5*W0/(EA*EB*PAI)
OPEN(4,FILE='OUT.DAT',STATUS='UNKNOWN')
OPEN(8,FILE='FILM.DAT',STATUS='UNKNOWN')
OPEN(10,FILE='PRESSURE.DAT',STATUS='UNKNOWN')
WRITE(*,*)N,X0,XE,W0,PH,E1,EDA0,RX,US
WRITE(4,*)N,X0,XE,W0,PH,E1,EDA0,RX,US
H00=0.0
MM=N-1
U=EDA0*US/(2.*E1*RX)
A1=ALOG(EDA0)+9.67
A2=5.1E-9*PH
A3=0.59/(PH*1.E-9)
B=PAI*PH*RX/E1
W=2.*PAI*PH/(3.*E1)*(B/RX)**2
ALFA=Z*5.1E-9*A1
G=ALFA*E1
AHM=1.0-EXP(-0.68*1.03)
HM0=3.63*(RX/B)**2*G**0.49*U**0.68*W**(-0.073)*AHM
ENDA=12.*U*(E1/PH)*(RX/B)**3
UTL=EDA0*US*RX/(B*B*2.E7)
W0=2.0*PAI*EA*EB*PH/3.0
WRITE(*,*)' Wait please'
CALL SUBAK(MM)
CALL MULTI(N,X0,XE,H00)
STOP
END
SUBROUTINE MULTI(N,X0,XE,H00)
DIMENSION X(65),Y(65),H(4500),RO(4500),EPS(4500),EDA(4500),P(4500),POLD(4500)
COMMON /COMEK/EK,EAL,EBE
DATA MK,G00/200,2.0943951/
G0=G00*EAL*EBE
NX=N
NY=N
NN=(N+1)/2
CALL INITI(N,DX,X0,XE,X,Y,P,POLD)
CALL HREE(N,DX,H00,G0,X,Y,H,RO,EPS,EDA,P)
M=0
14 KK=15
CALL ITER(N,KK,DX,H00,G0,X,Y,H,RO,EPS,EDA,P)
M=M+1
CALL ERP(N,ER,P,POLD)
WRITE(*,*)'ER=',ER
IF(M.LT.MK.AND.ER.GT.1.E-5)GOTO 14
CALL OUTPUT(N,DX,X,Y,H,P)
RETURN
END
SUBROUTINE ERP(N,ER,P,POLD)
DIMENSION P(N,N),POLD(N,N)
ER=0.0
SUM=0.0
NN=(N+1)/2
DO 10 I=1,N
DO 10 J=1,NN
ER=ER+ABS(P(I,J)-POLD(I,J))
SUM=SUM+P(I,J)
10 CONTINUE
ER=ER/SUM
DO I=1,N
DO J=1,N
POLD(I,J)=P(I,J)
ENDDO
ENDDO
RETURN
END
SUBROUTINE INITI(N,DX,X0,XE,X,Y,P,POLD)
DIMENSION X(N),Y(N),P(N,N),POLD(N,N)
NN=(N+1)/2
DX=(XE-X0)/(N-1.)
Y0=-0.5*(XE-X0)
DO 5 I=1,N
X(I)=X0+(I-1)*DX
Y(I)=Y0+(I-1)*DX
5 CONTINUE
DO 10 I=1,N
D=1.-X(I)*X(I)
DO 10 J=1,NN
C=D-Y(J)*Y(J)
IF(C.LE.0.0)P(I,J)=0.0
10 IF(C.GT.0.0)P(I,J)=SQRT(C)
DO 20 I=1,N
DO 20 J=NN+1,N
JJ=N-J+1
20 P(I,J)=P(I,JJ)
DO I=1,N
DO J=1,N
POLD(I,J)=P(I,J)
ENDDO
ENDDO
RETURN
END
SUBROUTINE HREE(N,DX,H00,G0,X,Y,H,RO,EPS,EDA,P)
DIMENSION X(N),Y(N),P(N,N),H(N,N),RO(N,N),EPS(N,N),EDA(N,N)
DIMENSION W(150,150),P0(150,150)
COMMON /COM1/ENDA,A1,A2,A3,Z,HM0/COMAK/AK(0:65,0:65)
COMMON /COMEK/EK,EAL,EBE
DATA NW,PAI,PAI1/150,3.14159265,0.2026423/
NN=(N+1)/2
CALL VI(NW,N,DX,P,W)
HMIN=1.E3
DO 30 I=1,N
DO 30 J=1,NN
RAD=X(I)*X(I)+EK*Y(J)*Y(J)
W1=0.5*RAD
H0=W1+W(I,J)
IF(H0.LT.HMIN)HMIN=H0
30 H(I,J)=H0
IF(KK.EQ.0)THEN
KG1=0
H01=-HMIN+HM0
DH=0.005*HM0
H02=-HMIN
H00=0.5*(H01+H02)
ENDIF
W1=0.0
DO 32 I=1,N
DO 32 J=1,N
32 W1=W1+P(I,J)
W1=DX*DX*W1/G0
DW=1.-W1
IF(KK.EQ.0)THEN
KK=1
GOTO 50
ENDIF
IF(DW.LT.0.0)THEN
KG1=1
H00=AMIN1(H01,H00+DH)
ENDIF
IF(DW.GT.0.0)THEN
KG2=2
H00=AMAX1(H02,H00-DH)
ENDIF
50 DO 60 I=1,N
DO 60 J=1,NN
H(I,J)=H00+H(I,J)
IF(P(I,J).LT.0.0)P(I,J)=0.0
EDA1=EXP(A1*(-1.+(1.+A2*P(I,J))**Z))
EDA(I,J)=EDA1
55 RO(I,J)=(A3+1.34*P(I,J))/(A3+P(I,J))
60 EPS(I,J)=RO(I,J)*H(I,J)**3/(ENDA*EDA1)
DO 70 J=NN+1,N
JJ=N-J+1
DO 70 I=1,N
H(I,J)=H(I,JJ)
RO(I,J)=RO(I,JJ)
EDA(I,J)=EDA(I,JJ)
70 EPS(I,J)=EPS(I,JJ)
RETURN
END
SUBROUTINE ITER(N,KK,DX,H00,G0,X,Y,H,RO,EPS,EDA,P)
DIMENSION X(N),Y(N),P(N,N),H(N,N),RO(N,N),EPS(N,N),EDA(N,N)
DIMENSION D(70),A(350),B(210),ID(70)
COMMON /COM1/ENDA,A1,A2,A3,Z,C3/COMAK/AK(0:65,0:65)
DATA KG1,PAI1,C1,C2/0,0.2026423,0.31,0.31/
IF(KG1.NE.0)GOTO 2
KG1=1
AK00=AK(0,0)
AK10=AK(1,0)
AK20=AK(2,0)
BK00=AK00-AK10
BK10=AK10-0.25*(AK00+2.*AK(1,1)+AK(2,0))
BK20=AK20-0.25*(AK10+2.*AK(2,1)+AK(3,0))
2 NN=(N+1)/2
MM=N-1
DX1=1./DX
DX2=DX*DX
DX3=1./DX2
DX4=0.3*DX2
DO 100 K=1,KK
PMAX=0.0
DO 70 J=2,NN
J0=J-1
J1=J+1
JJ=N-J+1
IA=1
8 MM=N-IA
IF(P(MM,J0).GT.1.E-6)GOTO 20
IF(P(MM,J).GT.1.E-6)GOTO 20
IF(P(MM,J1).GT.1.E-6)GOTO 20
IA=IA+1
IF(IA.LT.N)GOTO 8
GOTO 70
20 IF(MM.LT.N-1)MM=MM+1
D2=0.5*(EPS(1,J)+EPS(2,J))
DO 50 I=2,MM
I0=I-1
I1=I+1
II=5*I0
D1=D2
D2=0.5*(EPS(I1,J)+EPS(I,J))
D4=0.5*(EPS(I,J0)+EPS(I,J))
D5=0.5*(EPS(I,J1)+EPS(I,J))
P1=P(I0,JJ)
P2=P(I1,JJ)
P3=P(I,JJ)
P4=P(I,JJ+1)
P5=P(I,JJ-1)
D3=D1+D2+D4+D5
IF(J.EQ.NN.AND.ID(I).EQ.1)P(I,J)=P(I,J)-0.5*C2*D(I)
IF(H(I,J).LE.0.0)THEN
ID(I)=2
A(II+1)=0.0
A(II+2)=0.0
A(II+3)=1.0
A(II+4)=0.0
A(II+5)=1.0
A(II-4)=0.0
GOTO 50
ENDIF
IF(D1.GE.DX4)GOTO 30
IF(D2.GE.DX4)GOTO 30
IF(D4.GE.DX4)GOTO 30
IF(D5.GE.DX4)GOTO 30
ID(I)=1
IF(J.EQ.NN)P5=P4
A(II+1)=PAI1*(RO(I0,J)*BK10-RO(I,J)*BK20)
A(II+2)=DX3*(D1+0.25*D3)+PAI1*(RO(I0,J)*BK00-RO(I,J)*BK10)
A(II+3)=-1.25*DX3*D3+PAI1*(RO(I0,J)*BK10-RO(I,J)*BK00)
A(II+4)=DX3*(D2+0.25*D3)+PAI1*(RO(I0,J)*BK20-RO(I,J)*BK10)
A(II+5)=-DX3*(D1*P1+D2*P2+D4*P4+D5*P5-D3*P3)+DX1*(RO(I,J)*H(I,J)-RO(I0,J)*H(I0,J))
GOTO 50
30 ID(I)=0
P4=P(I,J0)
IF(J.EQ.NN)P5=P4
A(II+1)=PAI1*(RO(I0,J)*AK10-RO(I,J)*AK20)
A(II+2)=DX3*D1+PAI1*(RO(I0,J)*AK00-RO(I,J)*AK10)
A(II+3)=-DX3*D3+PAI1*(RO(I0,J)*AK10-RO(I,J)*AK00)
A(II+4)=DX3*D2+PAI1*(RO(I0,J)*AK20-RO(I,J)*AK10)
A(II+5)=-DX3*(D1*P1+D2*P2+D4*P4+D5*P5-D3*P3)+DX1*(RO(I,J)*H(I,J)-RO(I0,J)*H(I0,J))
50 CONTINUE
CALL TRA4(MM,D,A,B)
DO 60 I=2,MM
IF(ID(I).EQ.2)GOTO 60
IF(ID(I).EQ.0)GOTO 52
DD=D(I+1)
IF(I.EQ.MM)DD=0
P(I,J)=P(I,J)+C2*(D(I)-0.25*(D(I-1)+DD))
IF(J0.NE.1)P(I,J0)=P(I,J0)-0.25*C2*D(I)
IF(P(I,J0).LT.0.)P(I,J0)=0.0
IF(J1.GE.NN)GOTO 54
P(I,J1)=P(I,J1)-0.25*C2*D(I)
GOTO 54
52 P(I,J)=P(I,J)+C1*D(I)
54 IF(P(I,J).LT.0.0)P(I,J)=0.0
IF(PMAX.LT.P(I,J))PMAX=P(I,J)
60 CONTINUE
70 CONTINUE
DO 80 J=1,NN
JJ=N+1-J
DO 80 I=1,N
80 P(I,JJ)=P(I,J)
CALL HREE(N,DX,H00,G0,X,Y,H,RO,EPS,EDA,P)
100 CONTINUE
RETURN
END
SUBROUTINE TRA4(N,D,A,B)
DIMENSION D(N),A(5,N),B(3,N)
C=1./A(3,N)
B(1,N)=-A(1,N)*C
B(2,N)=-A(2,N)*C
B(3,N)=A(5,N)*C
DO 10 I=1,N-2
IN=N-I
IN1=IN+1
C=1./(A(3,IN)+A(4,IN)*B(2,IN1))
B(1,IN)=-A(1,IN)*C
B(2,IN)=-(A(2,IN)+A(4,IN)*B(1,IN1))*C
10 B(3,IN)=(A(5,IN)-A(4,IN)*B(3,IN1))*C
D(1)=0.0
D(2)=B(3,2)
DO 20 I=3,N
20 D(I)=B(1,I)*D(I-2)+B(2,I)*D(I-1)+B(3,I)
RETURN
END
SUBROUTINE VI(NW,N,DX,P,V)
DIMENSION P(N,N),V(NW,NW)
COMMON /COMAK/AK(0:65,0:65)
PAI1=0.2026423
DO 40 I=1,N
DO 40 J=1,N
H0=0.0
DO 30 K=1,N
IK=IABS(I-K)
DO 30 L=1,N
JL=IABS(J-L)
30 H0=H0+AK(IK,JL)*P(K,L)
40 V(I,J)=H0*DX*PAI1
RETURN
END
SUBROUTINE SUBAK(MM)
COMMON /COMAK/AK(0:65,0:65)
S(X,Y)=X+SQRT(X**2+Y**2)
DO 10 I=0,MM
XP=I+0.5
XM=I-0.5
DO 10 J=0,I
YP=J+0.5
YM=J-0.5
A1=S(YP,XP)/S(YM,XP)
A2=S(XM,YM)/S(XP,YM)
A3=S(YM,XM)/S(YP,XM)
A4=S(XP,YP)/S(XM,YP)
AK(I,J)=XP*ALOG(A1)+YM*ALOG(A2)+XM*ALOG(A3)+YP*ALOG(A4)
10 AK(J,I)=AK(I,J)
RETURN
END
SUBROUTINE OUTPUT(N,DX,X,Y,H,P)
DIMENSION X(N),Y(N),H(N,N),P(N,N)
NN=(N+1)/2
A=0.0
WRITE(8,110)A,(Y(I),I=1,N)
DO I=1,N
WRITE(8,110)X(I),(H(I,J),J=1,N)
ENDDO
WRITE(10,110)A,(Y(I),I=1,N)
DO I=1,N
WRITE(10,110)X(I),(P(I,J),J=1,N)
ENDDO
110 FORMAT(66(E12.6,1X))
RETURN
END

回復(fù)此樓

» 本帖附件資源列表

歡迎監(jiān)督和反饋：小木蟲(chóng)僅提供交流平臺(tái)，不對(duì)該內(nèi)容負(fù)責(zé)。
本內(nèi)容由用戶自主發(fā)布，如果其內(nèi)容涉及到知識(shí)產(chǎn)權(quán)問(wèn)題，其責(zé)任在于用戶本人，如對(duì)版權(quán)有異議，請(qǐng)聯(lián)系郵箱：xiaomuchong@tal.com
附件 1 : POINTEHL.f90

2013-07-27 10:37:59, 7.56 K

» 猜你喜歡

309分085801求調(diào)劑已經(jīng)有7人回復(fù)
生物學(xué)308分求調(diào)劑（一志愿華東師大）已經(jīng)有3人回復(fù)
求調(diào)劑：一志愿：南京大學(xué) 專業(yè)：0705 總分320 ，本科985，四六級(jí)已過(guò) 已經(jīng)有3人回復(fù)
環(huán)境工程 085701，267求調(diào)劑已經(jīng)有14人回復(fù)
308求調(diào)劑已經(jīng)有12人回復(fù)
求調(diào)劑：085600材料與化工，考材科基，總分319 已經(jīng)有21人回復(fù)
311求調(diào)劑已經(jīng)有8人回復(fù)
294分080500材料科學(xué)與工程求調(diào)劑已經(jīng)有13人回復(fù)
288求調(diào)劑一志愿哈工大材料與化工已經(jīng)有19人回復(fù)
288資源與環(huán)境專碩求調(diào)劑，不限專業(yè)，有學(xué)上就行已經(jīng)有23人回復(fù)

» 本主題相關(guān)價(jià)值貼推薦，對(duì)您同樣有幫助:

fortran里一個(gè)子程序不運(yùn)行是怎么回事已經(jīng)有13人回復(fù)
fortran讀寫問(wèn)題已經(jīng)有6人回復(fù)
一百個(gè)FORTRAN任務(wù)怎么能一次提交SSH計(jì)算已經(jīng)有3人回復(fù)
急求fortran運(yùn)行錯(cuò)誤原因，在線等已經(jīng)有7人回復(fù)
請(qǐng)教 fortran 運(yùn)行錯(cuò)誤的原因已經(jīng)有13人回復(fù)
FORTRAN新手求助主程序循環(huán)問(wèn)題已經(jīng)有10人回復(fù)
大家?guī)臀铱匆粋€(gè)fortran的程序，我總是計(jì)算不出正確的結(jié)果已經(jīng)有20人回復(fù)
請(qǐng)教一個(gè)fortran小程序編譯出錯(cuò)的問(wèn)題，謝謝已經(jīng)有9人回復(fù)
如何用fortran編寫高斯白噪聲程序已經(jīng)有6人回復(fù)
Fortran的格式化輸入輸出問(wèn)題已經(jīng)有14人回復(fù)
有關(guān)fortran的一次而問(wèn)題，希望大家能幫幫忙，謝謝已經(jīng)有4人回復(fù)
【求助】如何寫FORTRAN程序?qū)崿F(xiàn)求平均最近鄰距離已經(jīng)有34人回復(fù)
【求助】用fortran怎么描述下面這樣的情況，我是新手，請(qǐng)大家?guī)兔?/a> 已經(jīng)有8人回復(fù)

【求助】初學(xué)fortran，已經(jīng)有15人回復(fù)
【求助】請(qǐng)問(wèn)一下fortran的可視化編程已經(jīng)有7人回復(fù)
【交流】Fortran語(yǔ)言答疑專帖已經(jīng)有157人回復(fù)

1樓 2013-07-27 10:40:50

已閱回復(fù)此樓關(guān)注TA 給TA發(fā)消息送TA紅花 TA的回帖

pippi6

專家顧問(wèn)

工程和科學(xué)數(shù)值計(jì)算咨詢

應(yīng)助: 413 (碩士)
貴賓: 0.002
金幣: 7116.5
散金: 15
紅花: 63
帖子: 1639
在線: 798.9小時(shí)
蟲(chóng)號(hào): 2469437
注冊(cè): 2013-05-14
專業(yè): 計(jì)算數(shù)學(xué)與科學(xué)工程計(jì)算

【答案】應(yīng)助回帖

引用回帖:

3樓: Originally posted by 黑曼巴1991 at 2013-07-28 09:43:49
直接不能運(yùn)行沒(méi)有輸出結(jié)果。。幾個(gè)DAT文件都是空的。錯(cuò)誤信息發(fā)到附件里了麻煩看看，期待有結(jié)果，謝謝！

D0)FLF7U2802PMM}AX2{6WE.jpg

O05V}WLK6YAUI~~AW6BQU_U.jpg

Y4CBXDGY`CI6513HB{85[WL.jpg
...

把幾個(gè)do loop修改了一下，把標(biāo)號(hào)去掉了�？梢赃\(yùn)算了。沒(méi)出現(xiàn)你說(shuō)的問(wèn)題

PROGRAM POINTEHL
  DIMENSION THETA(15),EALFA(15),EBETA(15)
  COMMON /COM1/ENDA,A1,A2,A3,Z,HM0
  COMMON /COMEK/EK,EAL,EBE
  DATA N,PAI,Z,EAL,EBE,E1,EDA0,RX,RY,X0,XE,W0,US/65,3.14159265,0.68,1.0,1.0,2.21E11,0.0283,0.05,0.05,-2.5,1.5,39.24,1.5/
  DATA THETA/10.,20.,30.,35.,40.,45.,50.,55.,60.,65.,70.,75.,80.,85.,90./
  DATA EALFA/6.612,3.778,2.731,2.397,2.136,1.926,1.754,1.611,1.486,1.378,1.284,1.202,1.128,1.061,1.0/
  DATA EBETA/0.319,0.408,0.493,0.53,0.567,0.604,0.641,0.678,0.717,0.759,0.802,0.846,0.893,0.944,1.0/
  EK=RX/RY
  AA=0.5*(1./RX+1./RY)
  BB=0.5*ABS(1./RX-1./RY)
  CC=ACOS(BB/AA)*180.0/PAI
  DO I=1,15
   IF(CC.LT.THETA(I))THEN
      WRITE(*,*)I
      EAL=EALFA(I-1)+(CC-THETA(I))*(EALFA(I)-EALFA(I-1))/(THETA(I)-THETA(I-1))
      EBE=EBETA(I-1)+(CC-THETA(I))*(EBETA(I)-EBETA(I-1))/(THETA(I)-THETA(I-1))
      GOTO 1
   ENDIF
  ENDDO
1 EA=EAL*(1.5*W0/AA/E1)**(1./3.0)
  EB=EBE*(1.5*W0/AA/E1)**(1./3.0)
  PH=1.5*W0/(EA*EB*PAI)
  OPEN(4,FILE='OUT.DAT',STATUS='UNKNOWN')
  OPEN(8,FILE='FILM.DAT',STATUS='UNKNOWN')
  OPEN(10,FILE='PRESSURE.DAT',STATUS='UNKNOWN')
  WRITE(*,*)N,X0,XE,W0,PH,E1,EDA0,RX,US
  WRITE(4,*)N,X0,XE,W0,PH,E1,EDA0,RX,US
  H00=0.0
  MM=N-1
  U=EDA0*US/(2.*E1*RX)
  A1=ALOG(EDA0)+9.67
  A2=5.1E-9*PH
  A3=0.59/(PH*1.E-9)
  B=PAI*PH*RX/E1
  W=2.*PAI*PH/(3.*E1)*(B/RX)**2
  ALFA=Z*5.1E-9*A1
  G=ALFA*E1
  AHM=1.0-EXP(-0.68*1.03)
  HM0=3.63*(RX/B)**2*G**0.49*U**0.68*W**(-0.073)*AHM
  ENDA=12.*U*(E1/PH)*(RX/B)**3
  UTL=EDA0*US*RX/(B*B*2.E7)
  W0=2.0*PAI*EA*EB*PH/3.0
  WRITE(*,*)'             Wait please'
  CALL SUBAK(MM)
  CALL MULTI(N,X0,XE,H00)
  STOP
END PROGRAM POINTEHL

!flag
SUBROUTINE MULTI(N,X0,XE,H00)
  DIMENSION X(65),Y(65),H(4500),RO(4500),EPS(4500),EDA(4500),P(4500),POLD(4500)
  COMMON /COMEK/EK,EAL,EBE
  DATA MK,G00/200,2.0943951/
  G0=G00*EAL*EBE
  NX=N
  NY=N
  NN=(N+1)/2
  CALL INITI(N,DX,X0,XE,X,Y,P,POLD)
  CALL HREE(N,DX,H00,G0,X,Y,H,RO,EPS,EDA,P)
  M=0
14 KK=15
  CALL ITER(N,KK,DX,H00,G0,X,Y,H,RO,EPS,EDA,P)
  M=M+1
  CALL ERP(N,ER,P,POLD)
  WRITE(*,*)'ER=',ER
  IF(M.LT.MK.AND.ER.GT.1.E-5)GOTO 14
  CALL OUTPUT(N,DX,X,Y,H,P)
  RETURN
END SUBROUTINE MULTI

!flag
SUBROUTINE ERP(N,ER,P,POLD)
  DIMENSION P(N,N),POLD(N,N)
  ER=0.0
  SUM=0.0
  NN=(N+1)/2
  DO  I=1,N
   DO  J=1,NN
      ER=ER+ABS(P(I,J)-POLD(I,J))
      SUM=SUM+P(I,J)
   end DO
  end DO
  ER=ER/SUM
  DO I=1,N
   DO J=1,N
      POLD(I,J)=P(I,J)
   ENDDO
  ENDDO
  RETURN
END SUBROUTINE ERP

!flag
SUBROUTINE INITI(N,DX,X0,XE,X,Y,P,POLD)
  DIMENSION X(N),Y(N),P(N,N),POLD(N,N)
  NN=(N+1)/2
  DX=(XE-X0)/(N-1.)
  Y0=-0.5*(XE-X0)
  DO  I=1,N
   X(I)=X0+(I-1)*DX
   Y(I)=Y0+(I-1)*DX

  end DO

  DO I=1,N
   D=1.-X(I)*X(I)
   DO  J=1,NN
      C=D-Y(J)*Y(J)
      IF(C.LE.0.0)P(I,J)=0.0
      IF(C.GT.0.0)P(I,J)=SQRT(C)
   end DO
  end DO

  DO  I=1,N
   DO  J=NN+1,N
      JJ=N-J+1

      P(I,J)=P(I,JJ)
   ENDDO
  ENDDO

  DO I=1,N
   DO J=1,N
      POLD(I,J)=P(I,J)
   ENDDO
  ENDDO
  RETURN
END SUBROUTINE INITI

SUBROUTINE HREE(N,DX,H00,G0,X,Y,H,RO,EPS,EDA,P)
  DIMENSION X(N),Y(N),P(N,N),H(N,N),RO(N,N),EPS(N,N),EDA(N,N)
  DIMENSION W(150,150),P0(150,150)
  COMMON /COM1/ENDA,A1,A2,A3,Z,HM0/COMAK/AK(0:65,0:65)
  COMMON /COMEK/EK,EAL,EBE
  DATA NW,PAI,PAI1/150,3.14159265,0.2026423/
  NN=(N+1)/2
  CALL VI(NW,N,DX,P,W)
  HMIN=1.E3
  DO  I=1,N
   DO  J=1,NN
      RAD=X(I)*X(I)+EK*Y(J)*Y(J)
      W1=0.5*RAD
      H0=W1+W(I,J)
      IF(H0.LT.HMIN)HMIN=H0
30    H(I,J)=H0
   ENDDO
  ENDDO

  IF(KK.EQ.0)THEN
   KG1=0
   H01=-HMIN+HM0
   DH=0.005*HM0
   H02=-HMIN
   H00=0.5*(H01+H02)
  ENDIF
  W1=0.0
  DO  I=1,N
   DO  J=1,N
32    W1=W1+P(I,J)
   ENDDO
  ENDDO
  W1=DX*DX*W1/G0
  DW=1.-W1
  IF(KK.EQ.0)THEN
   KK=1
   GOTO 50
  ENDIF
  IF(DW.LT.0.0)THEN
   KG1=1
   H00=AMIN1(H01,H00+DH)
  ENDIF
  IF(DW.GT.0.0)THEN
   KG2=2
   H00=AMAX1(H02,H00-DH)
  ENDIF

50 continue
  DO  I=1,N
   DO  J=1,NN
      H(I,J)=H00+H(I,J)
      IF(P(I,J).LT.0.0)P(I,J)=0.0
      EDA1=EXP(A1*(-1.+(1.+A2*P(I,J))**Z))
      EDA(I,J)=EDA1
55    RO(I,J)=(A3+1.34*P(I,J))/(A3+P(I,J))
60    EPS(I,J)=RO(I,J)*H(I,J)**3/(ENDA*EDA1)
   end DO
  end DO

  DO  J=NN+1,N
   JJ=N-J+1
   DO  I=1,N
      H(I,J)=H(I,JJ)
      RO(I,J)=RO(I,JJ)
      EDA(I,J)=EDA(I,JJ)
70    EPS(I,J)=EPS(I,JJ)
   end DO

  end DO

  RETURN
END SUBROUTINE HREE

SUBROUTINE ITER(N,KK,DX,H00,G0,X,Y,H,RO,EPS,EDA,P)
  DIMENSION X(N),Y(N),P(N,N),H(N,N),RO(N,N),EPS(N,N),EDA(N,N)
  DIMENSION D(70),A(350),B(210),ID(70)
  COMMON /COM1/ENDA,A1,A2,A3,Z,C3/COMAK/AK(0:65,0:65)
  DATA KG1,PAI1,C1,C2/0,0.2026423,0.31,0.31/
  IF(KG1.NE.0)GOTO 2
  KG1=1
  AK00=AK(0,0)
  AK10=AK(1,0)
  AK20=AK(2,0)
  BK00=AK00-AK10
  BK10=AK10-0.25*(AK00+2.*AK(1,1)+AK(2,0))
  BK20=AK20-0.25*(AK10+2.*AK(2,1)+AK(3,0))
2 NN=(N+1)/2
  MM=N-1
  DX1=1./DX
  DX2=DX*DX
  DX3=1./DX2
  DX4=0.3*DX2
  DO  K=1,KK
   PMAX=0.0
   DO  J=2,NN
      J0=J-1
      J1=J+1
      JJ=N-J+1
      IA=1
8    MM=N-IA
      IF(P(MM,J0).GT.1.E-6)GOTO 20
      IF(P(MM,J).GT.1.E-6)GOTO 20
      IF(P(MM,J1).GT.1.E-6)GOTO 20
      IA=IA+1
      IF(IA.LT.N)GOTO 8
      cycle
20    IF(MM.LT.N-1)MM=MM+1
      D2=0.5*(EPS(1,J)+EPS(2,J))
      DO  I=2,MM
         I0=I-1
         I1=I+1
         II=5*I0
         D1=D2
         D2=0.5*(EPS(I1,J)+EPS(I,J))
         D4=0.5*(EPS(I,J0)+EPS(I,J))
         D5=0.5*(EPS(I,J1)+EPS(I,J))
         P1=P(I0,JJ)
         P2=P(I1,JJ)
         P3=P(I,JJ)
         P4=P(I,JJ+1)
         P5=P(I,JJ-1)
         D3=D1+D2+D4+D5
         IF(J.EQ.NN.AND.ID(I).EQ.1)P(I,J)=P(I,J)-0.5*C2*D(I)
         IF(H(I,J).LE.0.0)THEN
            ID(I)=2
            A(II+1)=0.0
            A(II+2)=0.0
            A(II+3)=1.0
            A(II+4)=0.0
            A(II+5)=1.0
            A(II-4)=0.0
            GOTO 50
         ENDIF
         IF(D1.GE.DX4)GOTO 30
         IF(D2.GE.DX4)GOTO 30
         IF(D4.GE.DX4)GOTO 30
         IF(D5.GE.DX4)GOTO 30
         ID(I)=1
         IF(J.EQ.NN)P5=P4
         A(II+1)=PAI1*(RO(I0,J)*BK10-RO(I,J)*BK20)
         A(II+2)=DX3*(D1+0.25*D3)+PAI1*(RO(I0,J)*BK00-RO(I,J)*BK10)
         A(II+3)=-1.25*DX3*D3+PAI1*(RO(I0,J)*BK10-RO(I,J)*BK00)
         A(II+4)=DX3*(D2+0.25*D3)+PAI1*(RO(I0,J)*BK20-RO(I,J)*BK10)
         A(II+5)=-DX3*(D1*P1+D2*P2+D4*P4+D5*P5-D3*P3)+DX1*(RO(I,J)*H(I,J)-RO(I0,J)*H(I0,J))
         GOTO 50
30       ID(I)=0
         P4=P(I,J0)
         IF(J.EQ.NN)P5=P4
         A(II+1)=PAI1*(RO(I0,J)*AK10-RO(I,J)*AK20)
         A(II+2)=DX3*D1+PAI1*(RO(I0,J)*AK00-RO(I,J)*AK10)
         A(II+3)=-DX3*D3+PAI1*(RO(I0,J)*AK10-RO(I,J)*AK00)
         A(II+4)=DX3*D2+PAI1*(RO(I0,J)*AK20-RO(I,J)*AK10)
         A(II+5)=-DX3*(D1*P1+D2*P2+D4*P4+D5*P5-D3*P3)+DX1*(RO(I,J)*H(I,J)-RO(I0,J)*H(I0,J))
50       CONTINUE
      end DO
      CALL TRA4(MM,D,A,B)
      DO  I=2,MM
         IF(ID(I).EQ.2)GOTO 60
         IF(ID(I).EQ.0)GOTO 52
         DD=D(I+1)
         IF(I.EQ.MM)DD=0
         P(I,J)=P(I,J)+C2*(D(I)-0.25*(D(I-1)+DD))
         IF(J0.NE.1)P(I,J0)=P(I,J0)-0.25*C2*D(I)
         IF(P(I,J0).LT.0.)P(I,J0)=0.0
         IF(J1.GE.NN)GOTO 54
         P(I,J1)=P(I,J1)-0.25*C2*D(I)
         GOTO 54
52       P(I,J)=P(I,J)+C1*D(I)
54       IF(P(I,J).LT.0.0)P(I,J)=0.0
         IF(PMAX.LT.P(I,J))PMAX=P(I,J)
60       CONTINUE
      end DO
70    CONTINUE
   end do
   DO J=1,NN
      JJ=N+1-J
      DO I=1,N
80       P(I,JJ)=P(I,J)
      end do
   end do
   CALL HREE(N,DX,H00,G0,X,Y,H,RO,EPS,EDA,P)
  end do
  RETURN
END SUBROUTINE ITER

SUBROUTINE TRA4(N,D,A,B)
  DIMENSION D(N),A(5,N),B(3,N)
  C=1./A(3,N)
  B(1,N)=-A(1,N)*C
  B(2,N)=-A(2,N)*C
  B(3,N)=A(5,N)*C
  DO  I=1,N-2
   IN=N-I
   IN1=IN+1
   C=1./(A(3,IN)+A(4,IN)*B(2,IN1))
   B(1,IN)=-A(1,IN)*C
   B(2,IN)=-(A(2,IN)+A(4,IN)*B(1,IN1))*C
10 B(3,IN)=(A(5,IN)-A(4,IN)*B(3,IN1))*C
  end DO
  D(1)=0.0
  D(2)=B(3,2)
  DO  I=3,N
20 D(I)=B(1,I)*D(I-2)+B(2,I)*D(I-1)+B(3,I)
  end DO
  RETURN
END SUBROUTINE TRA4

SUBROUTINE VI(NW,N,DX,P,V)
  DIMENSION P(N,N),V(NW,NW)
  COMMON /COMAK/AK(0:65,0:65)
  PAI1=0.2026423
  DO  I=1,N
   DO  J=1,N
      H0=0.0
      DO  K=1,N
         IK=IABS(I-K)
         DO  L=1,N
            JL=IABS(J-L)
30          H0=H0+AK(IK,JL)*P(K,L)
         end DO
      end DO
40    V(I,J)=H0*DX*PAI1
   end DO
  end DO
  RETURN
END SUBROUTINE VI

SUBROUTINE SUBAK(MM)
  COMMON /COMAK/AK(0:65,0:65)
  S(X,Y)=X+SQRT(X**2+Y**2)
  DO  I=0,MM
   XP=I+0.5
   XM=I-0.5
   DO J=0,I
      YP=J+0.5
      YM=J-0.5
      A1=S(YP,XP)/S(YM,XP)
      A2=S(XM,YM)/S(XP,YM)
      A3=S(YM,XM)/S(YP,XM)
      A4=S(XP,YP)/S(XM,YP)
      AK(I,J)=XP*ALOG(A1)+YM*ALOG(A2)+XM*ALOG(A3)+YP*ALOG(A4)
10    AK(J,I)=AK(I,J)
   end DO
  end DO
  RETURN
END SUBROUTINE SUBAK

SUBROUTINE OUTPUT(N,DX,X,Y,H,P)
  DIMENSION X(N),Y(N),H(N,N),P(N,N)
  NN=(N+1)/2
  A=0.0
  WRITE(8,110)A,(Y(I),I=1,N)
  DO I=1,N
   WRITE(8,110)X(I),(H(I,J),J=1,N)
  ENDDO
  WRITE(10,110)A,(Y(I),I=1,N)
  DO I=1,N
   WRITE(10,110)X(I),(P(I,J),J=1,N)
  ENDDO
110 FORMAT(66(E12.6,1X))
  RETURN
END SUBROUTINE OUTPUT

贊一下

回復(fù)此樓

4樓2013-07-28 15:08:23

已閱回復(fù)此樓關(guān)注TA 給TA發(fā)消息送TA紅花 TA的回帖

查看全部 6 個(gè)回答

pippi6

專家顧問(wèn)

工程和科學(xué)數(shù)值計(jì)算咨詢

應(yīng)助: 413 (碩士)
貴賓: 0.002
金幣: 7116.5
散金: 15
紅花: 63
帖子: 1639
在線: 798.9小時(shí)
蟲(chóng)號(hào): 2469437
注冊(cè): 2013-05-14
專業(yè): 計(jì)算數(shù)學(xué)與科學(xué)工程計(jì)算

【答案】應(yīng)助回帖

感謝參與，應(yīng)助指數(shù) +1

怎么錯(cuò)了？錯(cuò)誤信息是什么？你期待什么？

贊一下

回復(fù)此樓

2樓2013-07-28 08:37:29

已閱回復(fù)此樓關(guān)注TA 給TA發(fā)消息送TA紅花 TA的回帖

黑曼巴1991

實(shí)習(xí)版主

應(yīng)助: 4 (幼兒園)
金幣: 7421.6
散金: 335
紅花: 2
帖子: 938
在線: 292.5小時(shí)
蟲(chóng)號(hào): 2552663
注冊(cè): 2013-07-18
專業(yè): 傳動(dòng)機(jī)械學(xué)

引用回帖:

2樓: Originally posted by pippi6 at 2013-07-28 08:37:29
怎么錯(cuò)了？錯(cuò)誤信息是什么？你期待什么？

直接不能運(yùn)行沒(méi)有輸出結(jié)果。。幾個(gè)DAT文件都是空的。錯(cuò)誤信息發(fā)到附件里了麻煩看看，期待有結(jié)果，謝謝！

D0)FLF7U2802PMM}AX2{6WE.jpg

O05V}WLK6YAUI~~AW6BQU_U.jpg

Y4CBXDGY`CI6513HB{85[WL.jpg

贊一下

回復(fù)此樓

3樓2013-07-28 09:43:49

已閱回復(fù)此樓關(guān)注TA 給TA發(fā)消息送TA紅花 TA的回帖

黑曼巴1991

超級(jí)版主

應(yīng)助: 4 (幼兒園)
金幣: 7421.6
散金: 335
紅花: 2
帖子: 938
在線: 292.5小時(shí)
蟲(chóng)號(hào): 2552663
注冊(cè): 2013-07-18
專業(yè): 傳動(dòng)機(jī)械學(xué)

引用回帖:

4樓: Originally posted by pippi6 at 2013-07-28 15:08:23
把幾個(gè)do loop修改了一下，把標(biāo)號(hào)去掉了�？梢赃\(yùn)算了。沒(méi)出現(xiàn)你說(shuō)的問(wèn)題

PROGRAM POINTEHL
  DIMENSION THETA(15),EALFA(15),EBETA(15)
  COMMON /COM1/ENDA,A1,A2,A3,Z,HM0
  COMMON /COMEK/EK,EAL,EBE
...

我用你的試了一下還是一樣的問(wèn)題啊。。

奇怪了是不是我用的FTN95的原因？麻煩你給我發(fā)一下修改后的.90文件？、萬(wàn)分感謝！��！

贊一下

回復(fù)此樓

5樓2013-07-28 17:17:27

已閱回復(fù)此樓關(guān)注TA 給TA發(fā)消息送TA紅花 TA的回帖

查看全部 6 個(gè)回答

最具人氣熱帖推薦 [查看全部]		作者	回/看	最后發(fā)表

[考研] 一志愿北化085600材料專碩275\|有文章專利｜求調(diào)劑 +16	Micky11223 2026-03-25	17/850	2026-03-31 22:04 by 544594351
[考研] 一志愿南師大0703化學(xué) 275求調(diào)劑 +5	Ripcord上岸 2026-03-27	5/250	2026-03-31 19:52 by mg1014
[考研] 省雙一流重點(diǎn)一本大學(xué)招收調(diào)劑 +3	wwwwffffff 2026-03-31	5/250	2026-03-31 19:49 by 曾曾曾！
[考研] 085600 一志愿9 總分351 求調(diào)劑學(xué)校 +7	czhcz 2026-03-31	7/350	2026-03-31 18:54 by 小張做實(shí)驗(yàn)
[考研] 求調(diào)劑推薦材料 304 +18	荷包蛋hyj 2026-03-26	18/900	2026-03-31 18:08 by 544594351
[考研] 362求調(diào)劑 +9	西南交材料專碩3 2026-03-31	9/450	2026-03-31 16:25 by w蟲(chóng)蟲(chóng)123
[考研] 085404 22408 315分 +5	zhuangyan123 2026-03-31	6/300	2026-03-31 13:48 by limeifeng
[考研] 286求調(diào)劑 +5	丟掉懶惰 2026-03-27	8/400	2026-03-31 11:27 by Delta2012
[考研] 085600，專業(yè)課化工原理，320分求調(diào)劑 +6	大饞小子 2026-03-29	6/300	2026-03-31 10:03 by 氯化亞硝酰
[考研] 085600材料與化工調(diào)劑 +16	kikiki7 2026-03-30	16/800	2026-03-31 10:03 by 氯化亞硝酰
[考研] 291求調(diào)劑 +12	Y-cap 2026-03-29	15/750	2026-03-31 09:25 by Huaxue_Wang
[考研] 抱歉 +3	田洪有 2026-03-30	3/150	2026-03-30 19:11 by 迷糊CCPs
[考研] 0703一志愿9，初試成績(jī)：338，四六級(jí)已過(guò)，有科研經(jīng)歷，求調(diào)劑！ +7	Zuhui0306 2026-03-25	7/350	2026-03-30 19:01 by 源_2020
[考研] 0703 化學(xué) 求調(diào)劑，一志愿山東大學(xué) 342 分 +7	Shern—- 2026-03-28	7/350	2026-03-30 16:31 by nothing投稿中
[考研] 299求調(diào)劑 +10	15188958825 2026-03-25	10/500	2026-03-29 17:51 by 王亮_大連醫(yī)科大
[考研] 一志愿雙一流機(jī)械285分求調(diào)劑 +4	幸運(yùn)的三木 2026-03-29	5/250	2026-03-29 14:49 by Miko19
[考研] 2026年華南師范大學(xué)歡迎化學(xué)，化工，生物，生醫(yī)工等專業(yè)優(yōu)秀學(xué)子加入！ +3	llss0711 2026-03-28	6/300	2026-03-29 10:26 by llss0711
[考研] 339求調(diào)劑，想調(diào)回江蘇 +6	烤麥芽 2026-03-27	8/400	2026-03-28 10:40 by 烤麥芽
[考研] 081200-314 +3	LILIQQ 2026-03-27	4/200	2026-03-28 09:41 by 保護(hù)地球你我做?/a>
[考研] 348求調(diào)劑 +4	小懶蟲(chóng)不懶了 2026-03-27	5/250	2026-03-27 12:47 by 果果媽咪