戻る

C ********************************************************************* C
C C
C FIG - HF2D - FDM ( SV ) C
C C
C ( Version 3.9 ) C
C C
C Copyright : Yasuhiro MATSUDA C
C C
C Graphics Software for HF2D - FDM ( SV ) C
C C
C ********************************************************************* C
C
PROGRAM MAIN
C
IMPLICIT REAL*8 (A-H,O-Z)
C
C ***** DATA ( 1) ******************************************************
C
** PARAMETER ( IX= 21, IY= 21,
C
PARAMETER ( IX= 51, IY= 51,
C
** PARAMETER ( IX= 101, IY= 101,
C
C **********************************************************************
C
1 IX1= IX-1, IY1= IY-1, IXY= IX* IY,IXY1= IX1* IY1 )
C
C ------------------------------------------------------------
C
COMMON /LPN/ RAX( 250000), TMX( 250000), PMX( 250000), DNX(250000)
C
C ----- Attention --- Loop < = 250,000 ---
C
DIMENSION PSI( IXY), TEP( IXY), X( IXY), Y ( IXY),
1 NDE( IXY1,4), U ( IX,IY), V( IX,IY), HX( IX1),
2 HY ( IY1)
C
C ***** DATA ( 2) ******************************************************
C
** OPEN ( 7, FILE='F2D_FDM_E20_RE100_FIG.DAT' ) ! DT = 0.04
C
** OPEN ( 7, FILE='F2D_FDM_UE20_RE100_FIG.DAT' )
C
C ----------------------------------------------------------
C
** OPEN ( 7, FILE='F2D_FDM_E50_RE1000_FIG.DAT' ) ! DT = 0.02
C
OPEN ( 7, FILE='F2D_FDM_UE50_RE1000_FIG.DAT') ! DT = 0.008
C
C --------------------------------------------------------------------
C
** OPEN ( 7, FILE='HF2D_FDM_UE20_RA10_5_FIG.DAT' )
C
** OPEN ( 7, FILE='HF2D_FDM_E20_RA10_6_FIG.DAT')
C
C ----------------------------------------------------------
C
** OPEN ( 7, FILE='HF2D_FDM_UE50_RA10_5_FIG.DAT' )
C
** OPEN ( 7, FILE='HF2D_FDM_E50_RA10_6_FIG.DAT' ) ! DT = 0.00001
** OPEN ( 7, FILE='HF2D_FDM_UE50_RA10_6_FIG.DAT' )
C
** OPEN ( 7, FILE='HF2D_FDM_UE50_RA10_7_FIG.DAT' ) ! W = 0
** OPEN ( 7, FILE='W1_HF2D_FDM_UE50_RA10_7_FIG.DAT' )
** OPEN ( 7, FILE='W05_HF2D_FDM_UE50_RA10_7_FIG.DAT' )
** OPEN ( 7, FILE='HF2D_FDM_UE100_RA10_7_FIG.DAT' )
C
** OPEN ( 7, FILE='HF2D_FDM_UE100_RA10_8_FIG.DAT' )
C
C **********************************************************************
C
CALL TTLE
C
CALL PRPS ( PSI, TEP, U, V, HX, HY, X, Y, NDE,
1 NPL, MSH, KTF, RLN, IX, IY, IXY, IXY1 )
C
CALL VGA@
C
CALL PLVR ( RAX, NPL, 1, KTF )
C
C ----------------------------------------------------------
IF ( KTF.EQ.0) THEN
C
CALL PLVR ( PMX, NPL, 3, KTF )
C
CALL PLUV ( U, V, HX, HY, X, Y, KTF, RLN, IX, IY, IXY )
C
CALL PLCT ( X, Y, NDE, PSI, 3, IXY, IXY1, RLN )
C
END IF
C ----------------------------------------------------------
IF ( KTF.EQ.1) THEN
C
CALL PLVR ( TMX, NPL, 2, KTF )
C
CALL PLVR ( DNX, NPL, 4, KTF )
C
CALL PLCT ( X, Y, NDE, TEP, 1, IXY, IXY1, RLN )
C
CALL PLCT ( X, Y, NDE, PSI, 2, IXY, IXY1, RLN )
C
CALL PLUV ( U, V, HX, HY, X, Y, KTF, RLN,
1 IX, IY, IXY )
C
END IF
C ----------------------------------------------------------
C
IF ( MSH.EQ.1) CALL MSHF ( IX, IY )
C
C ----------------------------------------------------------
C
IF ( MSH.NE.1) CALL MSHP ( X, Y, IX, IY, IXY )
C
C ----------------------------------------------------------
C
STOP
END
C **********************************************************************
C
SUBROUTINE PLCT ( X, Y, NDE, TEP, KKK, IXY, IXY1, RLN )
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, X0, Y0, XIT, IWD, IX1, IY1, IX2, IY2
C
DIMENSION X ( IXY), Y ( IXY), NDE( IXY1,4), TEP( IXY)
DIMENSION PX( 4), PY( 4), HVA( 31)
C =========
RMI= 100.D0
RMX = 0.D0
C
C ------------------------------------------------
DO 100 I = 1, IXY
C
IF ( TEP( I).LE.RMI) RMI = TEP( I)
IF ( TEP( I).GE.RMX) RMX = TEP( I)
C
100 CONTINUE
C ------------------------------------------------
NM = 30
IF ( KKK.EQ.1) NM = 10
DRM = ( RMX - RMI)/ DFLOAT( NM )
C
IF ( DABS( RMX).GT.2.D0 .AND. KKK.EQ.2 ) DRM = 2.D0
IF ( DABS( RLN-1000000.D0) .LE.0.01 .AND. KKK.EQ.2) DRM = 2.D0
IF ( DABS( RLN-10000000.D0) .LE.0.01 .AND. KKK.EQ.2) DRM = 3.D0
IF ( DABS( RLN-100000000.D0).LE.0.01 .AND. KKK.EQ.2) DRM = 10.D0
C
C -------------------------------------------------------------------
IF ( RMI.LE.0.D0) RMI = 0.D0
C
IF ( KKK.EQ.1) WRITE(6,2000) KKK, RMI, RMX, DRM
2000 FORMAT(/,' ** KKK =',I3,' Tmin.=',F8.3,2X,' Tmax.=',F8.3,
1 ' DRM =',F8.3,/)
C
IF ( KKK.NE.1) WRITE(6,2100) KKK, RMI, RMX, DRM
2100 FORMAT(/,' ** KKK =',I3,' Rmin.=',F8.3,2X,' Rmax.=',F8.3,
1 ' DRM =',F8.3,/)
C
C --------------------------------------------------------------------
DO 200 I = 1, NM + 1
C
HVA( I) = RMX - DRM* DFLOAT( I-1)
200 CONTINUE
C ------------------------------------------------
C
ICR = 15
IWD = 160
C
X0 = 80
Y0 = 70
XIT = 190
YIT = 70
C -------------------------------------------------
IF ( KKK.EQ.1) THEN
CALL RECTANGLE@( X0, Y0, X0+IWD, Y0+IWD, ICR )
ICR = 12
GO TO 3344
END IF
C ------------------------------------------------
C
XIT = XIT + IWD + 20
X0 = X0 + 180
CALL RECTANGLE@( X0, Y0, X0+IWD, Y0+IWD, ICR )
C
ICR = 11
3344 CONTINUE
C ------------------------------------------------
SCLX = 160.D0
SCLY = 160.D0
C
C ----- To plot contour lines ---
C
PXV = 0.D0
PYV = 0.D0
C --------------------------------------------------------------------
DO 300 L = 1, IXY1
C
C ----------------------------------------------------------
DO 400 IH = 2, NM
C === Attention ===
C
HV = HVA( IH)
ICL = 0
C
C ------------------------------------------------
DO 500 J = 1, 4
C
I1 = NDE( L,J)
IF ( J.NE.4) THEN
I2 = NDE( L,J+1)
ELSE
I2 = NDE( L,1)
END IF
C
IF ( ABS( TEP( I1) - TEP( I2)).LE.0.000001) THEN
IF ( ABS( TEP( I1) - HV) .LE.0.000001) THEN
ICL = ICL + 1
PX( ICL) = X( I1)* SCLX
PY( ICL) = Y( I1)* SCLY
END IF
ELSE IF ((( TEP( I1).LE.HV) .AND. ( HV.LT.TEP( I2)))
1 .OR. (( TEP( I1).GE.HV) .AND. ( HV.GT.TEP( I2)))) THEN
C
ICL = ICL + 1
RT = ( HV - TEP( I1))/( TEP( I2) - TEP( I1))
PX( ICL) = ( X( I1) + ( X( I2) - X( I1))* RT)* SCLX
PY( ICL) = ( Y( I1) + ( Y( I2) - Y( I1))* RT)* SCLY
END IF
C
500 CONTINUE
C ------------------------------------------------
IF ( ICL.GE.2) THEN
C
C ------------------------------------------------
DO 600 J = 1, ICL
C
JM = J
D2 = ( PXV - PX( J))** 2 + ( PYV - PY( J))** 2
C
C --------------------------------------
DO 700 JJ = J+1, ICL
C
D2V = ( PXV - PX( JJ))** 2 + ( PYV - PY( JJ))** 2
IF ( D2V.LT.D2 ) THEN
JM = JJ
D2 = D2V
END IF
C
700 CONTINUE
C --------------------------------------
PXV = PX( JM)
PYV = PY( JM)
PX( JM) = PX( J)
PY( JM) = PY( J)
PX( J) = PXV
PY( J) = PYV
C
600 CONTINUE
C ------------------------------------------------
PXV = PX( ICL)
PYV = PY( ICL)
C
END IF
C
IF ( ICL.GT.0) THEN
C ------------------------------------------------
DO 800 J = 2, ICL
C
C ----- Attention ---
C
IX1 = X0 + IDNINT( PX( 1)) ! OK
IY1 = Y0 + IDNINT( PY( 1)) ! OK
IX2 = X0 + IDNINT( PX( J)) ! OK
IY2 = Y0 + IDNINT( PY( J)) ! OK
C
CALL DRAW_LINE@( IX1, IY1, IX2, IY2, ICR )
C
800 CONTINUE
C ------------------------------------------------
END IF
C
400 CONTINUE
C ----------------------------------------------------------
C
300 CONTINUE
C --------------------------------------------------------------------
C
RETURN
END
C **********************************************************************
C
SUBROUTINE PLUV ( U, V, HX, HY, X, Y, KTF, RLN, IX, IY,
1 IXY )
C
IMPLICIT REAL*8 (A-H,O-Z)
C
INTEGER*2 ICR, XIT, YIT, X0, Y0, X1, Y1, IWD
C
DIMENSION U( IX,IY), V( IX,IY), HX( IX-1), HY( IY-1),
1 X( IXY), Y( IXY)
C
ICR = 11
C
IWD = 160
X0 = 80
YIT = 70
Y0 = 70
SCL = 1.D0
C
IF ( RLN.LE.1.D4) SCL = 2.D0
IF ( RLN.GE.1.D5) SCL = 0.5D0
IF ( RLN.GE.1.D6) SCL = 0.05D0
IF ( RLN.GE.1.D7) SCL = 0.01D0
C
IF ( KTF.EQ.0) SCL = 20.D0
XIT = IWD - 80
IF ( KTF.EQ.1) XIT = 440
IF ( KTF.EQ.1) YIT = 100 + IWD
CALL RECTANGLE@( XIT, YIT, XIT + IWD, YIT + IWD, 15 )
C
IP = IX
JP = IY
C
C ----- Unequal length ---
C
C --------------------------------------
DO 100 I = 1, IX-1
C
HX( I) = HX( I)* DFLOAT( IWD)
100 CONTINUE
C --------------------------------------
DO 200 J = 1, IY-1
C
HY( J) = HY( J)* DFLOAT( IWD)
200 CONTINUE
C --------------------------------------
C
C ----- HYT: Total length of Y-Direction Size ---
C
HYT = 0.D0
C --------------------------------------
DO 300 I = 1, JP-1
C
HYT = HYT + HY( I)
300 CONTINUE
C ------------------------------------------------
DO 400 I = 2, IP
C
XXL = 0.D0
C --------------------------------------
DO 450 K = 1, I-1
C
XXL = XXL + HX( K)
450 CONTINUE
C --------------------------------------
C
HYD = 0.D0
C ------------------------------------------------
DO 400 J = 2, JP
C
X0 = IDNINT ( XXL) + XIT
HYD = HYD + HY( J-1)
Y0 = IDNINT( HYT - HYD) + YIT
C
C ----- Attention : Y - Plot Direction : Downward ---
C
X1 = X0 + IDNINT( U( I,J)* SCL )
Y1 = Y0 - IDNINT( V( I,J)* SCL )
C
C ----- Attention : Direction of 'j' : Downward ---
C
C ----- To omit 'PLOT' in case of 'UV'.LT.0.01 ---
C
CALL DRAW_LINE@( X0, Y0, X1, Y1, ICR )
C
400 CONTINUE
C ------------------------------------------------
C
RETURN
END
C **********************************************************************
C
SUBROUTINE PRPS ( PSI, TEP, U, V, HX, HY, X, Y,
1 NDE, NPL, MSH, KTF, RLN, IX, IY, IXY,
2 IXY1 )
C
IMPLICIT REAL*8 (A-H,O-Z)
C
DIMENSION PSI( IXY), TEP( IXY), U( IX,IY), V( IX,IY),
1 HX ( IX-1), HY ( IY-1), X( IXY), Y( IXY),
2 NDE( IXY1,4)
C
COMMON /LPN/ RAX( 250000),TMX( 250000), PMX( 250000), DNX(250000)
C
C ----- Attention --- Plotting Data ---
C
READ(7,1000) KTF, RLN, REN, DT, LOPE, MSH, NPLL
1000 FORMAT(I2, F12.1, F8.2, F11.8, I7, I2, I6)
C
IF ( NPLL.GT.250000)
1WRITE(6,*) ' ** No. Plotting > = 250000 * STOP * '
IF ( NPLL.GT.250000) STOP
C
WRITE(6,2000) KTF
2000 FORMAT(/,' *** KTF =', I2)
WRITE(6,2100) IX, IY
2100 FORMAT(/,' *** IX * IY =',I3,' X ',I3 )
C
NPL = NPLL - 1
C ===================
C
IF ( KTF.EQ.0) WRITE(6,2200) REN, DT, LOPE, MSH, NPL
2200 FORMAT(/,' ** Re =',F8.2,' DELT =',F11.8,' Loop =', I7,
1 ' MSH =', I2,' PLT =',I5 )
C
IF ( KTF.EQ.1) WRITE(6,2300) RLN, DT, LOPE, MSH, NPL
2300 FORMAT(' ** Ra =',F12.1,' DELT =',F9.6,' Loop =',I7,
1 ' MSH =',I2,' PLT =',I4 )
C
C ----- At the Last NPL --- Attention - NPL < = 250,000 ---
C
READ(7,1200) ( PSI( I), I= 1, IXY )
READ(7,1200) ( RAX( I), I= 1, NPL )
READ(7,1200) ( PMX( I), I= 1, NPL )
READ(7,1200) ( X ( I), I= 1, IXY )
READ(7,1200) ( Y ( I), I= 1, IXY )
READ(7,1200) (( U( I,J), J= 1, IY ), I= 1, IX )
READ(7,1200) (( V( I,J), J= 1, IY ), I= 1, IX )
READ(7,1200) ( HX( I), I= 1, IX-1 )
READ(7,1200) ( HY( I), I= 1, IY-1 )
C
1200 FORMAT(12F10.3)
C
READ(7,1300) (( NDE( I,J), J = 1, 4), I= 1, IXY1)
1300 FORMAT(20I6)
C
IF ( KTF.EQ.1) THEN
READ(7,1200) ( TEP( I), I= 1, IXY )
READ(7,1200) ( TMX( I), I= 1, NPL )
READ(7,1200) ( DNX( I), I= 1, NPL )
END IF
C
RETURN
END
C **********************************************************************
C
SUBROUTINE TTLE
C
IMPLICIT REAL*8 (A-H,O-Z)
C
WRITE(6,2000)
WRITE(6,2100)'***************************************************'
WRITE(6,2100)' '
WRITE(6,2100)' *** FIG - HF2D - FDM ( SV ) *** '
WRITE(6,2100)' '
WRITE(6,2100)' ( Version 3.9 ) '
WRITE(6,2100)' '
WRITE(6,2100)' 2D Thermal-Fluid Analysis by the 4th order FDM '
WRITE(6,2100)' '
WRITE(6,2100)' Copyright 2011 : Yasuhiro MATSUDA '
WRITE(6,2100)' '
WRITE(6,2100)'***************************************************'
2000 FORMAT(/)
2100 FORMAT(A55)
C
RETURN
END
C **********************************************************************
C
SUBROUTINE MSHF ( IX, IY )
C
IMPLICIT REAL*8 (A-H,O-Z)
C
INTEGER*2 ICR, XIT, YIT, IWD, IWK1, IWK2
C
COMMON /ABC/ XIT, YIT, IWD
C
ICR = 15
IWD = 160
XIT = 440
YIT = 70
CALL RECTANGLE@( XIT, YIT, XIT+IWD, YIT+IWD, ICR )
C
C --------------------------------------------------------------------
IWK2 = XIT + IWD
DO 100 I = 1, IX-1
C
IWK1 = YIT + IDNINT( DFLOAT( I)*( DFLOAT( IWD)/ DFLOAT( IX-1)))
CALL DRAW_LINE@( XIT, IWK1, IWK2, IWK1, ICR )
C
100 CONTINUE
C --------------------------------------------------------------------
IWK2 = YIT + IWD
DO 200 J = 1, IY-1
C
IWK1 = XIT + IDNINT( DFLOAT( J)*( DFLOAT( IWD)/ DFLOAT( IY-1)))
CALL DRAW_LINE@( IWK1, YIT, IWK1, IWK2, ICR )
C
200 CONTINUE
C --------------------------------------------------------------------
C
RETURN
END
C **********************************************************************
C
SUBROUTINE MSHP ( X, Y, IX, IY, IXY )
C
IMPLICIT REAL*8 (A-H,O-Z)
C
INTEGER*2 ICR, XIT, YIT, IWD, IWE, JWE
C
COMMON /ABC/ XIT, YIT, IWD
C
DIMENSION X( IXY), Y( IXY)
C
ICR = 15
IWD = 160
XIT = 440
YIT = 70
C
CALL RECTANGLE@( XIT, YIT, XIT+IWD, YIT+IWD, ICR )
C
C --------------------------------------------------------------------
DO 100 I = 1, IX + 1
C
JWE = IDNINT( Y( 1 + IY* ( I-1))* DFLOAT( IWD))
C
CALL DRAW_LINE@( XIT, YIT+JWE, XIT+IWD, YIT+JWE, ICR )
C
100 CONTINUE
C --------------------------------------------------------------------
DO 200 J = 1, IY+1
C
IWE = IDNINT( X( J+1)* DFLOAT( IWD))
C
CALL DRAW_LINE@( XIT+IWE, YIT, XIT+IWE, YIT+IWD, ICR )
C
200 CONTINUE
C --------------------------------------------------------------------
C
RETURN
END
C **********************************************************************
C
SUBROUTINE PLVR ( RWK, NPL, KKK, KTF )
C
IMPLICIT REAL*8 (A-H,O-Z)
C
INTEGER*2 ICR, IX0, IY0
C
C ----- Attention NPL .LE.500 ---
C
DIMENSION RWK ( 250000)
INTEGER*2 IVAR( 250000), IXX( 250000)
C
CHARACTER*80 STR0, STR3
CHARACTER*6 STR1( 3)
CHARACTER*3 STR2( 4)
C
DATA STR0 /'* HF2D-FDM(SV) ( Max_Var_of Vor.,Temp. (%) & Diff. of
1 Nu (Log.))'/
DATA STR3 /'* F2D-FDM(SV) ( Max.rel_var_of Vor.(%) & Psi(%))'/
C
DATA STR1 /'0 ','NPL/2',' NPL'/
DATA STR2 /' 20',' 15',' 10',' 5'/
C
C ----- Attention --- Max. Value ---
C
IF ( KKK.NE.1 ) GO TO 1234
C
ICR = 15
C
CALL SET_TEXT_ATTRIBUTE@( 3, 1., 0., 0. )
C
IF ( KTF.EQ.1) CALL DRAW_TEXT@( STR0, 70, 20, ICR )
IF ( KTF.EQ.0) CALL DRAW_TEXT@( STR3, 70, 20, ICR )
C
ICR = 15
CALL DRAW_TEXT@( STR1( 1), 50, 450, ICR )
CALL DRAW_TEXT@( STR1( 2), 310, 450, ICR )
CALL DRAW_TEXT@( STR1( 3), 590, 450, ICR )
CALL DRAW_TEXT@( ' 100', 10, 38, ICR )
CALL DRAW_TEXT@( ' 10', 10, 138, ICR )
CALL DRAW_TEXT@( ' 1', 10, 238, ICR )
CALL DRAW_TEXT@( ' 0.1', 10, 338, ICR )
CALL DRAW_TEXT@( '0.01', 10, 438, ICR )
CALL DRAW_TEXT@( '(%)',605, 255, ICR )
C
IF ( KTF.EQ.1) CALL DRAW_TEXT@( 'D_Nu', 7, 255, ICR )
CALL DRAW_TEXT@( STR2( 1), 600, 38, ICR )
CALL DRAW_TEXT@( STR2( 2), 600, 138, ICR )
CALL DRAW_TEXT@( STR2( 3), 600, 238, ICR )
CALL DRAW_TEXT@( STR2( 4), 600, 338, ICR )
C
IX0 = 50
IY0 = 40
CALL RECTANGLE@( IX0, IY0, IX0+580, IY0+400, 15 )
C
1234 CONTINUE
IX0 = 50
IY0 = 40
RIWD = 580.D0/ DFLOAT( NPL)
C
IF ( KKK.EQ.1) ICR = 15
IF ( KKK.EQ.2) ICR = 12
IF ( KKK.EQ.3) ICR = 11
IF ( KKK.EQ.4) ICR = 14
C
SCL = 10.D0
C
C ------------------------------------------------
IF ( KKK.EQ.4) THEN
C --------------------------------------
DO 100 I= 1, NPL
C
IF ( RWK( I).LE.0.D0) GO TO 100
RWK( I) = DLOG10( RWK( I))
C
100 CONTINUE
C --------------------------------------
SCL = 100.D0
END IF
C ------------------------------------------------
DO 200 I = 1, NPL
C
IXX ( I) = IX0 + IDNINT( DFLOAT( I)* RIWD )
IVAR( I) = IY0 + 400 - IDNINT( RWK( I)* SCL )
IF ( KKK.EQ.4) IVAR( I) = 240 - IDNINT( RWK( I)* SCL )
IF ( KTF.EQ.0)
1 IVAR( I) = IY0 + 400 - IDNINT( RWK( I)* 20.D0) ! Flow only
C
200 CONTINUE
C ------------------------------------------------
C
CALL POLYLINE@( IXX, IVAR, NPL, ICR )
C
RETURN
END
C **********************************************************************