戻る

C
PROGRAM MAIN
C *******************************************************************C
C C
C FIG - HF2D - FER C
C C
C Thermal Fluid Analysis Software by Finite Element Method C
C C
C ( Rectangular-Linear Element ) C
C C
C ( V.4.5 ) C
C C
C Copyright : Yasuhiro MATSUDA C
C C
C *******************************************************************C
C
IMPLICIT REAL*8(A-H,O-Z)
C
C ----- Attention ( 10 x 10 ) ---
C
DIMENSION X ( 121), Y ( 121), UN( 121), VN( 121), PSI( 121),
1 VOR( 121), TEP( 121)
C
INTEGER*2 NDE
C
DIMENSION NDE( 100,4)
C
COMMON /CST/ RE, RA, PRN
COMMON /TIM/ DT, LPM, LOP1, LOP, ALP
C
C ----- Attention --- < 2000 ---
C
COMMON /VPT/ VARV( 2000), VART( 2000), VRUV( 2000), VARP( 2000)
C
OPEN (10, FILE='HF2D_FER_PLT.DAT')
C
CALL TTLE
C
READ(10,1000) ICN, LOP, DT, RE, RA, PRN, NNP, NEL
1000 FORMAT( I2, I4, F6.3, 3F9.2, 2I4)
C
CALL PREP ( PSI, VOR, TEP, X, Y, UN, VN, NDE, ICN, NNP, NEL )
C
CALL VGA@
C
CALL MSHP ( X, Y, ICN )
C
CALL PLTN ( X, Y, UN, VN, NNP, ICN )
C
CALL PLVR ( VRUV, LOP, 1, ICN )
C
CALL PLVR ( VARP, LOP, 4, ICN )
C
IF ( ICN.EQ.0) CALL PLVR ( VARV, LOP, 3, ICN )
C
IF ( ICN.EQ.1) CALL PLVR ( VART, LOP, 2, ICN )
C
C ----- Attention : Change Direction ---
C
DO 100 I=1, NNP
C
SX = X( I)
X( I) = 1.D0 - Y( I)
Y( I) = SX
C
100 CONTINUE
C --------------------------------------
C
CALL PLCT ( X, Y, NDE, PSI, NNP, NEL, 0 )
C
IF ( ICN.EQ.1) CALL PLCT ( X, Y, NDE, TEP, NNP, NEL, 1 )
C
CLOSE ( 10)
C
STOP
END
C **********************************************************************
C
SUBROUTINE PLVR ( RAX, NPL, KKK, ICN )
C
IMPLICIT REAL*8(A-H,O-Z)
C
INTEGER*2 ICR, IX0, IY0
C
C ----- Attention NPL Data .LE.2000 ---
C
DIMENSION RAX( NPL)
C
INTEGER*2 IVAR( 2000), IXX( 2000)
C
CHARACTER*6 STR1(3)
CHARACTER*80 STR0, STR3
C
DATA STR0 /'* HF2D-FER (SV) ( Max_Var_of Str. funct., u-Velocity
1 & Temp.(%))'/
DATA STR3 /'* HF2D-FER (SV) ( Max.Var_of Str. funct., u-Velocity
1 & Vorticity(%))'/
DATA STR1/'0 ','NPL/2',' NPL'/
C
C ----- Attention --- Max. Value ---
C
IF ( KKK.GE.2) GO TO 1234
C
ICR = 15
C
CALL SET_TEXT_ATTRIBUTE@( 3, 1., 0., 0. )
C
IF ( ICN.EQ.1) CALL DRAW_TEXT@( STR0, 70, 20, ICR )
IF ( ICN.EQ.0) CALL DRAW_TEXT@( STR3, 70, 20, ICR )
C
ICR = 15
C
CALL DRAW_TEXT@( STR1(1), 47, 450, ICR )
CALL DRAW_TEXT@( STR1(2), 305, 450, ICR )
CALL DRAW_TEXT@( STR1(3), 585, 450, ICR )
C
IF ( KKK.NE.1) GO TO 133
C
CALL DRAW_TEXT@( '1000', 15, 35, ICR )
CALL DRAW_TEXT@( ' 100', 15, 115, ICR )
CALL DRAW_TEXT@( ' 10', 15, 195, ICR )
CALL DRAW_TEXT@( ' 1', 15, 275, ICR )
CALL DRAW_TEXT@( ' 0.1', 15, 355, ICR )
CALL DRAW_TEXT@( '0.01', 15, 435, ICR )
C
CALL DRAW_TEXT@( '(%)', 15, 240, ICR )
C
133 CONTINUE
C
IX0 = 50
IY0 = 40
C
CALL RECTANGLE@( IX0, IY0, IX0+580, IY0+400, 15 )
C
1234 CONTINUE
C
IX0 = 50
IY0 = 40
C
RIWD = 580.D0/ DFLOAT( NPL)
C
IF ( KKK.EQ.1) ICR = 11
IF ( KKK.EQ.2) ICR = 12
IF ( KKK.EQ.3) ICR = 9
IF ( KKK.EQ.4) ICR = 15
C
C ------------------------------------------------
DO 100 I = 1, NPL
C
IF ( RAX( I).LE.0.D0) GO TO 100
RAX( I) = DLOG10( RAX( I))
C
100 CONTINUE
C ------------------------------------------------
C
DO 200 I = 1, NPL
C
IXX( I) = IX0 + IDNINT( DFLOAT( I)* RIWD )
IVAR( I) = 280 - IDNINT( 80.D0* RAX( I))
C
200 CONTINUE
C ------------------------------------------------
C
CALL POLYLINE@( IXX, IVAR, NPL, ICR )
C
RETURN
END
C **********************************************************************
C
SUBROUTINE MSHP ( X, Y, ICN )
C
IMPLICIT REAL*8(A-H,O-Z)
C
INTEGER*2 ICR, ICR2, XIT, YIT, IWD, IWE, JWE
C
DIMENSION X( 121), Y( 121)
C
ICR = 15
ICR2 = 11
C
IWD = 160
C
XIT = 460
YIT = 250
IF ( ICN.EQ.0) YIT = 70
C
C ---------------------------------------
DO 100 I = 2, 10
C
JWE = Y( 1+12* ( I-1))* DFLOAT( IWD)
C
CALL DRAW_LINE@( XIT, YIT+JWE, XIT+IWD, YIT+JWE, ICR2 )
C
100 CONTINUE
C ---------------------------------------
DO 200 J = 1, 9
C
IWE = X( J+1)* DFLOAT( IWD )
C
CALL DRAW_LINE@( XIT+IWE, YIT, XIT+IWE, YIT+IWD, ICR2 )
C
200 CONTINUE
C ---------------------------------------------------------
C
CALL RECTANGLE@( XIT, YIT, XIT+IWD, YIT+IWD, ICR )
C
C ---------------------------------------------------------
C
RETURN
END
C **********************************************************************
C
SUBROUTINE PLCT ( X, Y, NDE, TEP, NNP, NEL, KCR )
C
C ----- To Plot Contour Lines for Rectangular Meshes ---
C
C ( Linear Interpolation )
C
IMPLICIT REAL*8(A-H,O-Z)
C
INTEGER*2 ICR, NDE, X0, Y0, IWD, PX, PY, XINT, YINT, ICR2
C
COMMON /SZC/ NEX, NEY
COMMON /ABC/ XINT, YINT, IWD
C
DIMENSION X ( NNP), Y ( NNP), NDE( NEL,4), TEP( NNP),
1 PX( 4), PY( 4), HVN( 21)
C
IWD = 160
ICR = 15
C
IF ( KCR.EQ.0) X0 = 100
IF ( KCR.EQ.1) X0 = 460
Y0 = 70
C
CALL RECTANGLE@( X0, Y0, X0 + IWD, Y0 + IWD, ICR )
C
SCX = 160.D0
SCY = 160.D0
NM = 10
C
TMIN = 100.D0
TMAX = - 100.D0
C -----------------------------------------------------
DO 100 I = 1, NNP
C
IF ( TEP( I).GE.TMAX) TMAX = TEP( I)
IF ( TEP( I).LE.TMIN) TMIN = TEP( I)
C
100 CONTINUE
C
WRITE(6,2000) TMAX, TMIN
2000 FORMAT(' * Cmax.=',F7.3,' * Cmin.=',F7.3)
C ---------------------------------------------------------------
DO 200 I = 1, NM
C
HVN( I) = TMIN + ( TMAX - TMIN)* DFLOAT( I)/ DFLOAT( NM)
C
200 CONTINUE
C ---------------------------------------------------------------
C
C ----- To Plot Contour Lines ---
C
IF ( KCR.EQ.0) ICR2 = 15
IF ( KCR.EQ.1) ICR2 = 12
IF ( KCR.EQ.2) ICR2 = 14
C
PXV = 0.D0
PYV = 0.D0
C
C -------------------------------------------------------------------
DO 300 L = 1, NEL
C
C ----------------------------------------------------------
DO 400 IH = 1, NM-1
C
HV = HVN( IH)
IL = 0
C
C -----------------------------------------------
DO 500 J = 1, 4
C
I1 = NDE( L,J)
C
IF ( J.NE.4) THEN
I2 = NDE( L,J+1)
ELSE
I2 = NDE( L,1)
END IF
C
IF ( DABS( TEP( I1)-TEP( I2)).LE.1.D-4 ) THEN
C
IF ( DABS( TEP( I1)-HV ).LE.1.D-4 ) THEN
IL = IL + 1
PX( IL) = X( I1)* SCX
PY( IL) = Y( I1)* SCY
END IF
C
ELSE IF (( ( TEP( I1).LE.HV ) .AND. ( HV.LT.TEP( I2)))
1 .OR. (( TEP( I1).GE.HV ) .AND. ( HV.GT.TEP( I2)))) THEN
C
IL = IL + 1
RT = ( HV - TEP( I1)) / ( TEP( I2) - TEP( I1))
C
PX( IL) = ( X( I1) + ( X( I2) - X( I1))*RT )* SCX
PY( IL) = ( Y( I1) + ( Y( I2) - Y( I1))*RT )* SCY
END IF
C
500 CONTINUE
C ------------------------------------------------
C
IF ( IL.GE.2 ) THEN
C
C ------------------------------------------------
DO 600 J = 1, IL
C
JM = J

C ----- Attention : D2 = ( PXV-PX( J))**2 + ( PYV-PY( J))**2 ---

D2 = ( PXV - DFLOAT( PX( J)))** 2 +
1 ( PYV - DFLOAT( PY( J)))** 2
C
C --------------------------------------
DO 650 JJ = J+1, IL
C
C --- Attention ---
C
C ---- D2V = ( PXV - PX( JJ))**2 + ( PYV - PY( JJ))**2 ---
C
D2V = ( PXV - DFLOAT(PX( JJ)))** 2 + ( PYV - DFLOAT(PY( JJ)))** 2
C
IF ( D2V.LT.D2) THEN
JM = JJ
D2 = D2V
END IF
C
650 CONTINUE
C --------------------------------------
C
PXV = PX( JM)
PYV = PY( JM)
C
PX( JM) = PX( J)
PY( JM) = PY( J)
C
PX( J) = PXV
PY( J) = PYV
C
600 CONTINUE
C -----------------------------------------------
C
PXV = PX( IL)
PYV = PY( IL)
C
END IF
C -----------------------------------------------
C
IF ( IL.GT.0 ) THEN
C -----------------------------------------------
DO 700 J = 2, IL
C
CALL DRAW_LINE@
C
1 ( X0+PY( J-1), Y0+PX( J-1), X0+PY( J), Y0+PX( J), ICR2 )
C
700 CONTINUE
C -----------------------------------------------
END IF
C
400 CONTINUE
C ----------------------------------------------------------
C
300 CONTINUE
C -------------------------------------------------------------------
C
RETURN
END
C **********************************************************************
C
SUBROUTINE PREP ( PSI, VOR, TEP, X, Y, UN, VN, NDE, ICN,
1 NNP, NEL )
C
IMPLICIT REAL*8(A-H,O-Z)
C
INTEGER*2 NDE
C
COMMON /SZC/ NEX, NEY
COMMON /CST/ RE, RA, PRN
COMMON /TIM/ DT, LPM, LOP1, LOP, ALP
COMMON /VPT/ VARV( 2000), VART( 2000), VRUV( 2000), VARP( 2000)
C
DIMENSION PSI( NNP), VOR( NNP), TEP( NNP), X( NNP), Y( NNP),
1 UN ( NNP), VN ( NNP), NDE( NEL,4 )
C
IF ( NEL.EQ.100) NEX = 10
IF ( NEL.EQ.100) NEY = 10
C
IF ( ICN.EQ.0) WRITE(6,2000) ICN, LOP, DT, RE, NNP, NEL
2000 FORMAT(' * ICN =',I2,' LOP =',I4,' DT =',F8.4,
1 ' Re =',F6.1,/,' NNP =',I4,' NEL =',I4,/ )
C
IF ( ICN.EQ.1 ) WRITE(6,2100) ICN, LOP, DT, RA, PRN, NNP, NEL
2100 FORMAT(' * ICN =',I2,' LOP =',I4,' DT =',F8.4,
1 ' Ra =',F9.1,' Pr =',F6.3,/,' NNP =',I4,' NEL ='
2 ,I4, / )
READ(10,1000) ( X( I), Y( I), I = 1, NNP )
1000 FORMAT(10F8.4)
READ(10,1100) (( NDE( I,J), I = 1, NEL ), J = 1, 4 )
1100 FORMAT(20I4)
C
C ----- At the Last LOP ---
C
READ(10,1200) ( VRUV( I), VARP( I), I = 1, LOP )
1200 FORMAT(10F11.5)
IF ( ICN.EQ.1) READ(10,1200) ( VARV( I), VART( I), I= 1, LOP )
IF ( ICN.EQ.0) READ(10,1200) ( VARV( I), I= 1, LOP )
READ(10,1000) ( UN( I), VN( I), I= 1, NNP )
IF ( ICN.EQ.1)
1READ(10,1000) ( PSI( I), VOR( I), TEP( I), I= 1, NNP )
IF ( ICN.EQ.0) READ(10,1000) ( PSI( I), VOR( I), I = 1, NNP)
C
RETURN
END
C **********************************************************************
C
SUBROUTINE TTLE
C
IMPLICIT REAL*8(A-H,O-Z)
C
WRITE(6,*) ' '
WRITE(6,*) 'C ************************************************* C'
WRITE(6,*) 'C C'
WRITE(6,*) 'C F I G - H F 2 D - F E R C'
WRITE(6,*) 'C C'
WRITE(6,*) 'C ( Version 4.5 ) C'
WRITE(6,*) 'C C'
WRITE(6,*) 'C 2D Thermal Fluid Analysis by FEM C'
WRITE(6,*) 'C C'
WRITE(6,*) 'C ( TRectangular Linear Element ) C'
WRITE(6,*) 'C C'
WRITE(6,*) 'C Copyright 2014 : Yasuhiro MATSUDA C'
WRITE(6,*) 'C C'
WRITE(6,*) 'C ************************************************* C'
WRITE(6,*) ' '
C
RETURN
END
C **********************************************************************
C
SUBROUTINE PLTN ( X, Y, UN, VN, NNP, ICN )
C
IMPLICIT REAL*8(A-H,O-Z)
C
INTEGER*2 ICR, IWD, IX0, IY0, IX1, IY1, IX2, IY2, GX, GY
C
DIMENSION X( NNP), Y( NNP), UN( NNP), VN( NNP)
C
COMMON /TIM/ DT, LPM, LOP1, LOP, ALP
C
SCX = 240.D0
SCY = 240.D0
C
IF ( ICN.EQ.0) SCL = 20.D0
IF ( ICN.EQ.1) SCL = 5.D0
C
ICR = 15
C
IX0 = 280
IY0 = 70
IWD = 160
c
TL = DT* DFLOAT( LOP)
C
IX1 = IX0 + IWD
IY1 = IY0 + IWD
C
CALL RECTANGLE@( IX0, IY0, IX1, IY1, ICR )
C
ICR = 11
C
C -----------------------------------------------------
DO 100 I = 1, NNP
C
GX = IX0 + X( I)* IWD
GY = IY0 + IWD - Y( I)* IWD
C
IF ( GX.EQ.IX0 ) GO TO 100
IF ( GY.EQ.IY0 ) GO TO 100
IF ( GX.EQ.IX0+IWD) GO TO 100
IF ( GY.EQ.IY0+IWD) GO TO 100
C
IX1 = GX
IY1 = GY
IX2 = GX + UN( I)* SCL
IY2 = GY - VN( I)* SCL
C
CALL DRAW_LINE@( IX1, IY1, IX2, IY2, ICR )
C
100 CONTINUE
C ----------------------------------------------------
C
RETURN
END
C **********************************************************************