📄 a30.for
字号:
C
C
ND2=ND*(ND + 1)/2
C
DO 10 I = 1,ND
DO 10 J = 1,ND
AS(I,J)=0.D0
10 CONTINUE
C
DO 20 I = 1,ND2
ST(I)=0.D0
20 CONTINUE
C
IF (MODEL.EQ.2) GO TO 100
C
C
J1=NDIR(1)
AS(J1,J1)=STF(1)
C
IF (IELDT.EQ.1) GO TO 200
C
J2=NDIR(2)
IR=6 + J2
IF (NODEM(1).EQ.NODEM(2)) IR=J2
AS(IR,IR)=STF(1)
AS(IR,J1)=-STF(1)
AS(J1,IR)=-STF(1)
GO TO 200
C
C
100 CONTINUE
C
K=0
C
C
DO 160 IR = 1,IELDT
DO 150 IF = 1,6
IF (IDOF(IF).EQ.1) GO TO 150
IFR=(IR - 1)*6 + IF
C
C
DO 140 IC = IR,IELDT
LL=1
IF (IC.EQ.IR) LL=IF
DO 130 IP = LL,6
IF (IDOF(IP).EQ.1) GO TO 130
ICF=(IC - 1)*6 + IP
K=K + 1
AS(IFR,ICF)=STF(K)
130 CONTINUE
140 CONTINUE
150 CONTINUE
160 CONTINUE
C
DO 170 I = 1,ND
DO 170 J = 1,ND
AS(J,I)=AS(I,J)
170 CONTINUE
C
200 CONTINUE
C
K=0
DO 210 I = 1,ND
DO 210 J = I,ND
K=K + 1
ST(K)=AS(I,J)
210 CONTINUE
C
RETURN
END
SUBROUTINE GLEMAS (XM,ST,AS,ND,MODEL,IMASS,NDIR,IELDT,NODEM)
C
C
C
C
C***ADD:DPR***
IMPLICIT DOUBLE PRECISION ( A-H,O-Z )
C***END:DPR***
COMMON /MDFRDM/ IDOF(12)
C
DIMENSION XM(*),ST(*),AS(ND,*),NDIR(*),NODEM(*)
C
C
C
ND2=ND*(ND + 1)/2
C
DO 10 I = 1,ND
DO 10 J = 1,ND
AS(I,J)=0.D0
10 CONTINUE
C
DO 20 I = 1,ND2
ST(I)=0.D0
20 CONTINUE
C
IF (MODEL.EQ.2) GO TO 100
C
C
J1=NDIR(1)
XT=XM(1)/2.
IF (IMASS.EQ.2) XT=XM(1)/3.
IF (IELDT.EQ.1) XT=XM(1)
AS(J1,J1)=XT
C
IF (IELDT.EQ.1) GO TO 200
C
J2=NDIR(2)
IR=6 + J2
IF (NODEM(1).EQ.NODEM(2)) IR=J2
AS(IR,IR)=XT
IF (IMASS.NE.2) GO TO 200
AS(J1,IR)=XT/2.
AS(IR,J1)=XT/2.
GO TO 200
C
C
100 CONTINUE
C
IF (IMASS.NE.2) GO TO 160
C
C
K=0
C
C
DO 140 IR = 1,IELDT
DO 130 IF = 1,6
IF (IDOF(IF).EQ.1) GO TO 130
IRF=(IR - 1)*6 + IF
C
C
DO 120 IC = IR,IELDT
LL=1
IF (IC.EQ.IR) LL=IF
DO 110 IP = LL,6
IF (IDOF(IP).EQ.1) GO TO 110
ICF=(IC - 1)*6 + IP
K=K + 1
AS(IRF,ICF)=XM(K)
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
C
DO 150 I = 1,ND
DO 150 J = 1,ND
AS(J,I)=AS(I,J)
150 CONTINUE
C
GO TO 200
C
C LUMPED MASS MATRIX
C
160 CONTINUE
C
K=0
DO 180 IR = 1,IELDT
DO 170 IF = 1,6
IF (IDOF(IF).EQ.1) GO TO 170
IRF=(IR - 1)*6 + IF
K=K + 1
AS(IRF,IRF)=XM(K)
170 CONTINUE
180 CONTINUE
C
200 CONTINUE
C
IF (IMASS.NE.2) GO TO 230
C
K=0
DO 210 I = 1,ND
DO 210 J = I,ND
K=K + 1
ST(K)=AS(I,J)
210 CONTINUE
GO TO 250
C
230 CONTINUE
C
DO 240 I = 1,ND
ST(I)=AS(I,I)
240 CONTINUE
C
250 CONTINUE
C
RETURN
END
SUBROUTINE GLEDMP (XC,ST,AS,ND,MODEL,IDAMP,NDIR,IELDT,NODEM)
C
C
C
C
C***ADD:DPR***
IMPLICIT DOUBLE PRECISION ( A-H,O-Z )
C***END:DPR***
COMMON /MDFRDM/ IDOF(12)
C
DIMENSION XC(*),ST(*),AS(ND,*),NDIR(*),NODEM(*)
C
C
C
ND2=ND*(ND + 1)/2
C
DO 10 I = 1,ND
DO 10 J = 1,ND
AS(I,J)=0.D0
10 CONTINUE
C
DO 20 I = 1,ND2
ST(I)=0.D0
20 CONTINUE
C
IF (MODEL.EQ.2) GO TO 100
C
C
J1=NDIR(1)
XT=XC(1)
AS(J1,J1)=XT
C
IF (IELDT.EQ.1) GO TO 200
C
J2=NDIR(2)
IR=6 + J2
IF (NODEM(1).EQ.NODEM(2)) IR=J2
AS(IR,IR)=XT
IF (IDAMP.EQ.1) GO TO 200
AS(J1,IR)=-XT
AS(IR,J1)=-XT
GO TO 200
C
C
100 CONTINUE
C
IF (IDAMP.EQ.1) GO TO 160
C
C
K=0
C
C
DO 140 IR = 1,IELDT
DO 130 IF = 1,6
IF (IDOF(IF).EQ.1) GO TO 130
IRF=(IR - 1)*6 + IF
C
C
DO 120 IC = IR,IELDT
LL=1
IF (IC.EQ.IR) LL=IF
DO 110 IP = LL,6
IF (IDOF(IP).EQ.1) GO TO 110
ICF=(IC - 1)*6 + IP
K=K + 1
AS(IRF,ICF)=XC(K)
110 CONTINUE
120 CONTINUE
130 CONTINUE
140 CONTINUE
C
DO 150 I = 1,ND
DO 150 J = 1,ND
AS(J,I)=AS(I,J)
150 CONTINUE
C
GO TO 200
C
C
160 CONTINUE
C
K=0
DO 180 IR = 1,IELDT
DO 170 IF = 1,6
IF (IDOF(IF).EQ.1) GO TO 170
IRF=(IR - 1)*6 + IF
K=K + 1
AS(IRF,IRF)=XC(K)
170 CONTINUE
180 CONTINUE
C
200 CONTINUE
C
IF (IDAMP.EQ.1) GO TO 230
C
K=0
DO 210 I = 1,ND
DO 210 J = I,ND
K=K + 1
ST(K)=AS(I,J)
210 CONTINUE
GO TO 250
C
230 CONTINUE
C
DO 240 I = 1,ND
ST(I)=AS(I,I)
240 CONTINUE
C
250 CONTINUE
C
RETURN
END
SUBROUTINE FORCAL (ST,RE,AS,DISP,ND)
C
C
C
C
C***ADD:DPR***
IMPLICIT DOUBLE PRECISION ( A-H,O-Z )
C***END:DPR***
DIMENSION ST(*),RE(*),AS(ND,*),DISP(*)
C
C
C
DO 10 I = 1,ND
DO 10 J = 1,ND
AS(I,J)=0.D0
10 CONTINUE
C
N=0
DO 20 I = 1,ND
DO 20 J = I,ND
N=N + 1
AS(I,J)=ST(N)
AS(J,I)=AS(I,J)
20 CONTINUE
C
C
DO 40 I = 1,ND
TEMP=0.D0
DO 30 J = 1,ND
TEMP=TEMP + AS(I,J)*DISP(J)
30 CONTINUE
RE(I)=TEMP
40 CONTINUE
C
RETURN
END
SUBROUTINE STRCAL (CS,AS,RE,DISP,NDIR,NSTRES,
1 MODEL,ND,IELDT,NODEM)
C
C
C
C
C***ADD:DPR***
IMPLICIT DOUBLE PRECISION ( A-H,O-Z )
C***END:DPR***
COMMON /MDFRDM/ IDOF(12)
C
DIMENSION CS(*),AS(NSTRES,*),RE(*),DISP(*),NDIR(*)
1 ,NODEM(*)
C
C
C
DO 10 I = 1,NSTRES
RE(I)=0.D0
DO 10 J = 1,ND
AS(I,J)=0.D0
10 CONTINUE
C
IF (MODEL.EQ.2) GO TO 100
C
C
J1=NDIR(1)
AS(1,J1)=CS(1)
C
IF (IELDT.EQ.1) GO TO 20
J2=NDIR(2)
IR=6 + J2
IF (NODEM(1).EQ.NODEM(2)) IR=J2
AS(1,IR)=-CS(1)
C
20 CONTINUE
TEMP=0.D0
DO 30 J = 1,ND
TEMP=TEMP + AS(1,J)*DISP(J)
30 CONTINUE
RE(1)=TEMP
40 CONTINUE
C
GO TO 200
C
C
100 CONTINUE
C
K=0
DO 140 J = 1,NSTRES
DO 130 L = 1,IELDT
DO 120 LL = 1,6
IF (IDOF(LL).EQ.1) GO TO 120
IC=(L - 1)*6 + LL
K=K + 1
AS(J,IC)=CS(K)
120 CONTINUE
130 CONTINUE
140 CONTINUE
C
C
DO 170 I = 1,NSTRES
TEMP=0.D0
DO 160 J = 1,ND
TEMP=TEMP + AS(I,J)*DISP(J)
160 CONTINUE
RE(I)=TEMP
170 CONTINUE
C
200 CONTINUE
C
RETURN
END
SUBROUTINE PRNSTF (STF,XM,XC,CS,AS,IMS,NSTRES,IMASS,IDAMP,
1 NDS,NDC)
C
C
C
C***ADD:DPR***
IMPLICIT DOUBLE PRECISION ( A-H,O-Z )
C***END:DPR***
C
DIMENSION STF(*),XM(*),XC(*),CS(*),AS(NDC,*),PR(9),IMS(3)
C
CHARACTER*4 ACOL(2), AROW
DATA ACOL /' CO' , 'LUMN'/ , AROW /' ROW'/
C
C
C
IF (IMS(1).NE.1) GO TO 100
IKMCS=1
NDD=NDS
C
C
write(66,1000)
C
C
K=0
DO 10 I = 1,NDS
DO 10 J = I,NDS
K=K + 1
AS(I,J)=STF(K)
AS(J,I)=AS(I,J)
10 CONTINUE
C
C
15 CONTINUE
RN=FLOAT(NDS)/9. + 0.99
NR=RN
C
C
DO 50 I = 1,NR
NBR=(I - 1)*9 + 1
NCR=NBR + 8
IF (NCR.GT.NDS) NCR=NDS
IF (I.EQ.1) write(66,1100)
1 (ACOL(1),ACOL(2),I1,I1=NBR,NCR)
IF (I.GT.1) write(66,1200)
1 (ACOL(1),ACOL(2),I1,I1=NBR,NCR)
DO 40 J=1,NDD
K=0
DO 30 L = NBR,NCR
K=K + 1
PR(K)=AS(J,L)
30 CONTINUE
IF (J.LE.9) write(66,1300)
1 AROW,J,(PR(K1),K1=1,K)
IF (J.GT.9) write(66,1400)
1 AROW,J,(PR(K1),K1=1,K)
40 CONTINUE
50 CONTINUE
GO TO (100,190,200,300),IKMCS
C
C
100 CONTINUE
IF (IMS(2).NE.1) GO TO 190
IKMCS=2
NDD=NDS
write(66,1500)
C
C
DO 105 I = 1,NDS
DO 105 J = 1,NDS
AS(I,J)=0.D0
105 CONTINUE
C
IF (IMASS.NE.2) GO TO 120
C
C
K=0
DO 110 I = 1,NDS
DO 110 J = I,NDS
K=K + 1
AS(I,J)=XM(K)
AS(J,I)=AS(I,J)
110 CONTINUE
GO TO 140
C
C LUMPED MASS MATRIX
C
120 CONTINUE
DO 130 I = 1,NDS
AS(I,I)=XM(I)
130 CONTINUE
C
140 CONTINUE
GO TO 15
C
C
190 IF (IMS(3).NE.1) GO TO 200
IKMCS=3
NDD=NDS
write(66,1550)
C
DO 192 I=1,NDS
DO 192 J=1,NDS
AS(I,J)=0.D0
192 CONTINUE
C
IF (IDAMP.EQ.1) GO TO 195
C
C
K=0
DO 194 I=1,NDS
DO 194 J=I,NDS
K=K+1
AS(I,J)=XC(K)
AS(J,I)=AS(I,J)
194 CONTINUE
GO TO 199
C
C
195 CONTINUE
DO 197 I=1,NDS
AS(I,I)=XC(I)
197 CONTINUE
C
199 CONTINUE
GO TO 15
C
C
200 CONTINUE
IF (NSTRES.LE.0) GO TO 300
IKMCS=4
NDD=NSTRES
write(66,1600)
C
C
K=0
DO 210 I = 1,NSTRES
DO 210 J = 1,NDS
K=K + 1
AS(I,J)=CS(K)
210 CONTINUE
GO TO 15
C
300 CONTINUE
C
RETURN
C
1000 FORMAT (//1H ,18H STIFFNESS MATRIX/)
C
1100 FORMAT (///1H ,7X,9(3X,A4,A4,I2))
C
1200 FORMAT (///1H ,8X,9(2X,A4,A4,I3))
C
1300 FORMAT (/1H ,1X,A4,I2,3X,9E13.5)
C
1400 FORMAT (/1H ,1X,A4,I3,2X,9E13.5)
C
1500 FORMAT (//1H ,13H MASS MATRIX/)
1550 FORMAT (//1H ,16H DAMPING MATRIX/)
C
1600 FORMAT (//1H ,30H STRESS TRANSFORMATION MATRIX/)
C
C*FILE END
END⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -