Tidas_main

戻る

C
PROGRAM MAIN
C ******************************************************************** C
C C
C TIFDAS_FIG C
C C
C ( No - Fig_Meshes ) C
C C
C ( Version 5.4 ) C
C C
C Copyright : Yasuhiro MATSUDA C
C C
C ******************************************************************** C
C
INTEGER*2 NDE
C
DIMENSION UE( 116), VE ( 116), C( 81), X( 81), Y( 81), X1( 81),
1 Y1( 81), NDE( 116,3)
C
C ----- Attention : LOP < = 500 ---
C
DIMENSION UR( 500), VR( 500), ZR( 500)
C
COMMON /PLTD/ XR( 100), YR( 100)
C
CALL TTLE
C
OPEN ( 9, FILE='REPV.DAT')
OPEN ( 10, FILE='UV.DAT' )
OPEN ( 11, FILE='PLOT.DAT')
C
OPEN ( 15, FILE='LAND.DAT')
OPEN ( 16, FILE='ISLE.DAT')
OPEN ( 30, FILE='CONC.DAT')
C
READ(11,*) NNP, NEL
READ(10,*) LOP
C
CALL INPD ( UE, VE, UR, VR, ZR, C, X, Y, NDE,
1 NNP, NEL, LOP, KY )
C
CALL VGA@
C
*** CALL OTLN ( NLIN, ILINE, X, Y, NNP )
C
IF ( KY.LE.2) CALL PLTV ( X, Y, X1, Y1, UE, VE, NDE, NNP, NEL )
C
IF ( KY.EQ.2) CALL PLTC ( X, Y, X1, Y1, C, NDE, NNP, NEL )
C
IF ( KY.EQ.3) CALL PLVR ( ZR, LOP, 1 )
C
IF ( KY.EQ.3) CALL PLVR ( UR, LOP, 2 )
C
IF ( KY.EQ.3) CALL PLVR ( VR, LOP, 3 )
C
CLOSE ( 9)
CLOSE ( 10)
CLOSE ( 11)
CLOSE ( 15)
CLOSE ( 16)
CLOSE ( 30)
C
STOP
END
C ***********************************************************************
C
SUBROUTINE INPD ( UE, VE, UR, VR, ZR, C, X, Y, NDE,
1 NNP, NEL, LOP, KY )
C
INTEGER*2 NDE
C
DIMENSION UE( NEL), VE( NEL), C( NNP), X( NNP), Y( NNP),
1 NDE( NEL,3)
C
DIMENSION UR( LOP), VR( LOP), ZR( LOP)
C
WRITE(6,2000) NNP, NEL, LOP
2000 FORMAT(' *** NNP =', I5, ' NEL =',I5,' Loop =',I5,/)
C
C --------------------------------------
DO 100 I = 1, NEL
C
READ(10,*) UE( I), VE( I)
100 CONTINUE
C --------------------------------------
DO 200 I = 1, NEL
C
UE( I) = UE( I)* 100.
VE( I) = VE( I)* 100.
C
200 CONTINUE
C --------------------------------------
DO 300 I = 1, NNP
C
READ(11,* ) X( I), Y( I)
300 CONTINUE
C --------------------------------------
DO 400 I = 1, NEL
C
READ(11,* ) ( NDE ( I,J), J = 1, 3)
400 CONTINUE
C ------------------------------------------------
DO 500 I = 1, LOP
C
READ(9,*) NNN, J, UR( I), VR( I), ZR( I)
500 CONTINUE
C ------------------------------------------------
WRITE(6,*) ' *** KY(?) = 1 ( Velocity Distr. only )'
WRITE(6,*) ' = 2 ( Velocity & Concentration )'
WRITE(6,*) ' = 3 ( Variance of u, v, z ) '
C
READ(6,*) KY
REWIND 30
C
IF ( KY.EQ.2) READ(30,*) ( C( I), I = 1, NNP )
C
RETURN
END
C ***********************************************************************
C
SUBROUTINE OTLN ( NLIN, ILINE, X, Y, NNP )
C
C ----- MESH-ZU ---
C
INTEGER*2 ICR, IWD, IX0, IY0, IX1, IY1, IX2, IY2
C
DIMENSION ILINE( NLIN), X( NNP), Y( NNP)
C
ICR = 15
C
IX0 = 100
IY0 = 70
IWD = 160
C
DO 100 I = 1, NLIN
C
N = ILINE((I-1)* 2 + 1)
IX1 = X( N)* IWD + IX0
IY1 = Y( N)* IWD + IY0
C
N = ILINE( I* 2)
IX2 = X( N)* IWD + IX0
IY2 = Y( N)* IWD + IY0
C
CALL DRAW_LINE@( IX1, IY1, IX2, IY2, ICR )
C
100 CONTINUE
C
RETURN
END
C ***********************************************************************
C
SUBROUTINE PLTC ( X, Y, XX, YY, C, NDE, NNP, NEL )
C
COMMON /PLTD/ XR( 100), YR( 100)
C
INTEGER*2 X0, Y0, X1, Y1, IYH
INTEGER*2 NDE, CON
C
DIMENSION X( NNP), Y( NNP), XX( NNP), YY( NNP), C( NNP),
1 NDE( NEL,3)
C
REWIND 15
REWIND 16
C
IYH = 200
C
DO 100 I = 1, NNP
C
XX( I) = X ( I)/ 400. + 0.05D0
YY( I) = Y ( I)/ 400. + 0.05D0
YY( I) = YY( I) + IYH
C
100 CONTINUE
C
C ------- Land Boundary ---
C
DO 200 I = 1, 34
C
READ(15,1000) XRB, YRB
1000 FORMAT(2X, F4.0, 2X, F4.0)
C
XR( I) = XRB* 225./400. + 0.05D0
YR( I) = YRB* 225./400. + 0.05D0
C
200 CONTINUE
C
C ------------------------------------------------
DO 300 I = 1, 33
C
X0 = XR( I)
Y0 = YR( I) + IYH
X1 = XR( I+1 )
Y1 = YR( I+1 ) + IYH
C
CALL DRAW_LINE@( X0, Y0, X1, Y1, 15 )
C
300 CONTINUE
C ------------------------------------------------
C
C ----- Island Boundary ---
C
C ------------------------------------------------
DO 400 I = 1, 11
C
READ(16,1100) XRI, YRI
1100 FORMAT(2x,f4.0,2x,f4.0)
C
XR( I) = XRI* 225./ 400. + 0.05D0
YR( I) = YRI* 225./ 400. + 0.05D0
C
400 CONTINUE
C ------------------------------------------------
DO 500 I = 1, 10
C
X0 = XR( I)
Y0 = YR( I) + IYH
X1 = XR( I+1)
Y1 = YR( I+1) + IYH
C
CALL DRAW_LINE@( X0, Y0, X1, Y1, 15 )
C
500 CONTINUE
C ------------------------------------------------
C
CON = 0
C
CALL TCNT ( XX, YY, NDE, C, NNP, NEL, CON )
C
RETURN
END
C ***********************************************************************
C
SUBROUTINE PLTV ( X, Y, XX, YY, UE, VE, NDE, NNP, NEL )
C
COMMON /PLTD/ XR( 100), YR( 100)

INTEGER*2 X0, Y0, X1, Y1

INTEGER*2 NDE
DIMENSION X ( NNP), Y ( NNP), XX( NNP), YY( NNP), UE( NEL),
1 VE( NEL), NDE( NEL,3)
C
S = SIN( 0.2)
C = COS( 0.2)
C
EPS = 0.0001
ALSCI = 0.01
C
C --------------------------------------
DO 100 I = 1, NNP
C
XX( I) = X( I)/ 400. + 0.05D0
YY( I) = Y( I)/ 400. + 0.05D0
C
100 CONTINUE
C --------------------------------------
DO 200 I = 1, NEL
C
C --- Garavity point ---
C
X0 = ( XX( NDE ( I,1)) + XX( NDE ( I,2))
1 + XX( NDE ( I,3)))/ 3.
C
Y0 = ( YY( NDE ( I,1)) + YY( NDE ( I,2))
1 + YY( NDE ( I,3)))/ 3.
X1 = X0 - UE( I)
Y1 = Y0 - VE( I)
C
CALL DRAW_LINE@( X0, Y0, X1, Y1, 11 )
C
200 CONTINUE
C --------------------------------------
C
C ----- Land Boundary ---
C
C --------------------------------------
DO 300 I = 1, 34
C
READ(15,1000) XRB, YRB
1000 FORMAT(2X,F4.0,2X,F4.0 )
C
XR( I) = XRB* 225./ 400. + 0.05D0
YR( I) = YRB* 225./ 400. + 0.05D0
C
300 CONTINUE
C --------------------------------------
DO 400 I = 1, 33
C
X0 = XR( I)
Y0 = YR( I)
X1 = XR( I+1)
Y1 = YR( I+1)
C
CALL DRAW_LINE@( X0, Y0, X1, Y1, 15 )
C
400 CONTINUE
C -------------------------------------
C
C ----- Island Boundary ---
C
DO 500 I = 1, 11
C
READ(16,1100) XRI, YRI
1100 FORMAT(2X,F4.0,2X,F4.0)
C
C ----- Need to follow ---
C
XR( I) = XRI* 225./ 400. + 0.05D0
YR( I) = YRI* 225./ 400. + 0.05D0
C
500 CONTINUE
C --------------------------------------
DO 600 I = 1, 10
C
X0 = XR( I)
Y0 = YR( I)
X1 = XR( I+1)
Y1 = YR( I+1)
C
CALL DRAW_LINE@( X0, Y0, X1, Y1, 15 )
C
600 CONTINUE
C --------------------------------------
C
RETURN
END
C ***********************************************************************
C
SUBROUTINE PLVR ( RMAX, LOP, KY )

INTEGER*2 ICR, IX0, IY0, IWD
C
C ----- Attention N .LE. 500 ---
C
DIMENSION RMAX( LOP )

INTEGER*2 IVAR( 500), IXX( 500)
C
CHARACTER*70 STR0
CHARACTER*4 STR1( 4)
CHARACTER*5 STR2( 5)
C
DATA STR0 /' *** TIFDAS *** ( Variance of Water level & Velo
1city )'/
DATA STR1 /' 0',' 100',' 200',' 300'/
DATA STR2 /' 100 ',' 50 ',' 0 ',' -50 ','-100 '/
C
IF ( KY.GE.2) GO TO 111
C
ICR = 15
C
CALL SET_TEXT_ATTRIBUTE@( 3, 1., 0., 0. )

CALL DRAW_TEXT@( STR0, 70, 20, ICR )
C
ICR = 15
C
CALL DRAW_TEXT@( STR1( 1), 5, 450, ICR )
CALL DRAW_TEXT@( STR1( 2), 205, 450, ICR )
CALL DRAW_TEXT@( STR1( 3), 405, 450, ICR )
CALL DRAW_TEXT@( STR1( 4), 605, 450, ICR )

CALL DRAW_TEXT@( STR2( 1), 0, 40, ICR )
CALL DRAW_TEXT@( STR2( 2), 0, 140, ICR )
CALL DRAW_TEXT@( STR2( 3), 0, 240, ICR )
CALL DRAW_TEXT@( STR2( 4), 0, 340, ICR )
CALL DRAW_TEXT@( STR2( 5), 0, 440, ICR )
C
IX0 = 35
IY0 = 50
C
CALL RECTANGLE@( IX0, IY0, IX0+600, IY0+400, ICR )
C
111 CONTINUE
IF ( KY.EQ.1) ICR = 15
IF ( KY.EQ.2) ICR = 14
IF ( KY.EQ.3) ICR = 13
C
IWD = 600/ LOP
IWD = 2
C
C ------------------------------------------------
DO 100 I = 1, LOP-1
C
IXX ( I) = IX0 + I* IWD
IVAR( I) = IY0 + 200 - RMAX( I)* 200.
C
100 CONTINUE
C ------------------------------------------------
C
CALL POLYLINE@( IXX, IVAR, LOP-1, ICR )
C
C ------------------------------------------------
C
RETURN
END
C ***********************************************************************
C
SUBROUTINE TCNT ( X, Y, NDE, TEP, NNP, NEL, CON )
C
C ----- To plot Contour lines for Triangular Linear Meshes ---
C
INTEGER*2 NDE, LC, CON
INTEGER*2 ICR, IWD, IX0, IY0, IX1, IY1, IX2, IY2, IX3, IY3
C
DIMENSION X ( NNP), Y ( NNP), NDE( NEL,3), TEP( NNP), PX( 4),
1 PY( 4), LC( 56), HVN( 100)
C
IX0 = 0
IY0 = 0
C
IWD = 1
SCLX = 1.
SCLY = 1.
C
ICR = 15
C
C ----- To Plot Contour Lines ---
C
ICR = 14
C
PXV = 0.
PYV = 0.
C
ICL = 0
NM = 12
C
TMIN = 3.
TMAX = 0.
C
DO 30 I = 1, NM
C
HVN( I) = TMIN + ( TMAX - TMIN)* FLOAT( I)/ FLOAT( NM)
30 CONTINUE
C
DO 50 I = 1, 56
C
LC( I) = 6
50 CONTINUE
C
PXV = 0.
PYV = 0.
C
C ----------------------------------------------------------
DO 100 L = 1, NEL
C
C ------------------------------------------------
DO 200 IH = 1, NM
C
HV = HVN( IH )
ICL = 0
C
C --------------------------------------
DO 300 J = 1, 3
C
I1 = NDE( L, J )
IF ( J .NE.3 ) THEN
I2 = NDE( L, J + 1 )
ELSE
I2 = NDE( L, 1 )
END IF
C
IF ( ABS( TEP(I1) - TEP(I2)).LE.0.001 ) THEN
C
IF ( ABS( TEP(I1) - HV ).LE. 0.001) THEN
ICL = ICL + 1
PX( ICL) = X( I1)* SCLX
PY( ICL) = Y( I1)* SCLY
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
ICL = ICL + 1
RT = ( HV - TEP( I1))/ ( TEP( I2) - TEP( I1))
PX( ICL) = ( X( I1) + ( X( I2) - X( I1))* RT )* IWD
PY( ICL) = ( Y( I1) + ( Y( I2) - Y( I1))* RT )* IWD
END IF
C
300 CONTINUE
C --------------------------------------
C
IF ( ICL.GE.2) THEN
C
D2V = 0.
C ============
C
C ----------------------------------------------------------
DO 400 J = 1, ICL
C
JM = J
D2 = ( PXV - PX( J))** 2 + ( PYV - PY( J))** 2
C
C ------------------------------------------------
DO 500 JJ = J + 1, ICL
C
IF ( D2V.LT.D2) THEN
JM = JJ
D2 = D2V
END IF
C
500 CONTINUE
C ------------------------------------------------
C
PXV = PX( JM)
PYV = PY( JM)
PX( JM) = PX( J)
PY( JM) = PY( J)
PX( J) = PXV
PY( J) = PYV
C
400 CONTINUE
C ----------------------------------------------------------
C
PXV = PX( ICL)
PYV = PY( ICL)
END IF
C
IF ( ICL.GT.0) THEN
C
C ------------------------------------------------
DO 600 J = 2, ICL
C
IX1 = IX0 + PX( J-1)
IY1 = IY0 + PY( J-1)
IX2 = IX0 + PX( J)
IY2 = IY0 + PY( J)
C
CALL DRAW_LINE@( IX1, IY1, IX2, IY2, 12 )
C
600 CONTINUE
C ------------------------------------------------
IF ( ICL.EQ.3 ) THEN
IX3 = IX0 + PX( 1)
IY3 = PY( I)
C
CALL DRAW_LINE@( IX2, IY2, IX3, IY3, 12 )
C
END IF
C
END IF
C
200 CONTINUE
C ------------------------------------------------
C
100 CONTINUE
C ---------------------------------------------------------
C
RETURN
END
C ***********************************************************************
C
SUBROUTINE TTLE
C
WRITE(6,100)
WRITE(6,101)'C ************************************************ C'
WRITE(6,101)'C C'
WRITE(6,101)'C Graphics for Tidal Flow & Diffusion C'
WRITE(6,101)'C C'
WRITE(6,101)'C Analysis by F.E.M. C'
WRITE(6,101)'C C'
WRITE(6,101)'C TIFDAS_FIG C'
WRITE(6,101)'C C'
WRITE(6,101)'C ( V.5.4 ) C'
WRITE(6,101)'C C'
WRITE(6,101)'C Copyright 2011 : Yasuhiro MATSUDA C'
WRITE(6,101)'C C'
WRITE(6,101)'C ************************************************ C'
WRITE(6,100)
C
100 FORMAT(/)
101 FORMAT(1X,A60)
C
RETURN
END
C ***********************************************************************