PROGRAM IMP4GFILE
C=======================================================================
C FINITE ELEMENT GRAPHICS FOR
C TIME DEPENDENT TWO-DIMENSIONAL POTENTIAL PROBLEMS
C ELEMENT TYPE: FOUR-NODED ISOPARAMETRIC ELEMENT
C CREATE FILES CONTAINING XY-COORDINTE VALUES
C ORIGINAL CODE: NSEQ8GRA.FOR, EIJI FUKUMORI, JULY 1985
C FEBRUARY 05, 2013
C=======================================================================
INCLUDE 'PARAM.DAT'
IMPLICIT REAL*8 ( A-H , O-Z )
CCCCC PARAMETER ( MXE=30000,MXN=33000,MXB=10000,ND=4)
C ARRAYS
DIMENSION NODEX(MXE,ND),ISEG(MXE,ND)
DIMENSION IBND(MXB), BV(MXB), ITYPE(MXB)
DIMENSION XCOORD(MXN),YCOORD(MXN),POTEN(MXN)
DIMENSION S(ND), BX(2,ND)
C=======================================================================
WRITE (*,*)'============ POTENTIAL GRAPHICS PROGRAM ============'
CALL INPUT ( MXE,MXN,MXB,ND,NE,NNODE,NB,NODEX,XCOORD,YCOORD,
* POTEN,IBND,ITYPE, BV )
C=======================================================================
CALL PLTEL4 ( ND,MXE,MXN,NODEX,NE,XCOORD,YCOORD )
CALL POTENTL (MXE,MXN,ND,NE,NNODE,NODEX,XCOORD,YCOORD,POTEN,S,BX)
STOP 'NORMAL TERMINATION'
END
C
C
SUBROUTINE INPUT ( MXE,MXN,MXB,ND,NE,NNODE,NB,NODEX,XCOORD,
* YCOORD,POTEN,IBND,ITYPE, BV )
IMPLICIT REAL*8 ( A-H , O-Z )
DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN),IBND(MXB),
* POTEN(MXN),ITYPE(MXB),BV(MXB)
LOGICAL YES
C========> FILE IMP4Q.DAT OPEN
OPEN ( 1, FILE='IMP4Q.DAT', STATUS='UNKNOWN' )
READ (1,*)
READ (1,*)
READ (1,*)
READ (1,*)
C========> ELEMENT
READ (1,*) NE
DO I = 1 , NE
READ (1,*) IEL, ( NODEX(IEL,J), J = 1 , ND )
END DO
C========> COORDINATES
READ (1,*) NNODE
DO I = 1 , NNODE
READ (1,*) NODE, XCOORD(NODE) , YCOORD(NODE)
END DO
C========> BOUNDARY CONDITIONS
READ(1,*) NB
DO I = 1 , NB
READ (1,*) IBND(I) , ITYPE(I), BV(I)
END DO
CLOSE (1)
C========> POTENTIAL VALUE FILENAME=SOLUTION.BIN
OPEN (1,FILE='SOLUTION.BIN',STATUS='UNKNOWN',FORM='UNFORMATTED')
READ (1) ( POTEN(I) , I = 1 , NNODE )
CLOSE (1)
RETURN
END
C
C
SUBROUTINE POTENTL ( MXE,MXN,ND,NE,NNODE,NODEX,XCOORD,YCOORD,
* POTEN,S,B )
IMPLICIT REAL*8 ( A-H , O-Z )
DIMENSION S(ND),NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN),
* B(2,ND),POTEN(MXN)
CHARACTER FILENAME*12
FILENAME = 'POTENTAL.OUT'
CALL PLTLGO (FILENAME)
CALL CONTOUR (MXE,MXN,ND,NE,NNODE,NODEX,XCOORD,YCOORD,S,B,POTEN )
CALL PLTEXT
RETURN
END
C
C
SUBROUTINE CONTOUR (MXE,MXN,ND,NE,NNODE,NODEX,XCOORD,YCOORD,S,B,P)
IMPLICIT REAL*8 ( A-H , O-Z )
DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN),P(MXN),
* S(ND),B(2,ND)
C
CALL MINMAX ( MXN, NNODE, P, PPMIN , PPMAX )
IF ( PPMAX .EQ. PPMIN ) RETURN
NSTEP = 16
DS = ( PPMAX - PPMIN ) / NSTEP
I = PPMIN/DS + 0.5
PPMIN = I*DS
C
CALL BOUND ( MXE,MXN,ND,NE,NODEX,XCOORD,YCOORD )
C
DO IEL = 1 , NE
DO I = 1 , ND
B(1,I) = XCOORD(NODEX(IEL,I))
B(2,I) = YCOORD(NODEX(IEL,I))
S(I) = P(NODEX(IEL,I))
END DO
CALL PLTSAI ( ND, DS, NSTEP, PPMIN, B, S )
END DO
RETURN
END
C
C
SUBROUTINE PLTSAI ( ND, DS, NSTEP, START, CRD, S )
IMPLICIT REAL*8 ( A-H , O-Z )
DIMENSION CRD(2,ND), S(ND)
IF ( NSTEP .EQ. 0 ) RETURN
DO LEVEL = 1 , NSTEP
SXY = START + (LEVEL-1) * DS
K = 1
DO I = 1 , ND
J = I + 1
IF ( I .EQ. ND ) J = 1
IF ( (S(I)-SXY)*(S(J)-SXY) .LT. 0 ) THEN
T=(SXY-S(I))/(S(J)-S(I))
X0=CRD(1,J)*T+(1.D0-T)*CRD(1,I)
Y0=CRD(2,J)*T+(1.D0-T)*CRD(2,I)
IF ( K .GT. 0 ) THEN
CALL XMOVE ( X0, Y0 )
ELSE
CALL XDRAW ( X0, Y0 )
END IF
K = -K
END IF
END DO
END DO
RETURN
END
C
C
SUBROUTINE BOUND ( MXE,MXN,ND,NE,NODEX,XCOORD,YCOORD )
IMPLICIT REAL*8 ( A-H , O-Z )
DIMENSION XCOORD(MXN),YCOORD(MXN),NODEX(MXE,ND)
LOGICAL LINE
C
DO IEL = 1 , NE
DO I = 1 , ND
LINE = .TRUE.
J = I + 1
IF ( I .EQ. ND ) J = 1
C
DO JEL = 1 , NE
IF ( IEL .NE. JEL ) THEN
DO II = 1 , ND
JJ = II + 1
IF ( II .EQ. ND ) JJ = 1
IF ( NODEX(IEL,I).EQ.NODEX(JEL,JJ) .AND.
* NODEX(IEL,J).EQ.NODEX(JEL,II) ) THEN
LINE = .FALSE.
EXIT
END IF
END DO
END IF
IF ( .NOT. LINE ) EXIT
END DO
IF ( LINE ) THEN
CALL XMOVE ( XCOORD(NODEX(IEL,I)),YCOORD(NODEX(IEL,I)) )
CALL XDRAW ( XCOORD(NODEX(IEL,J)),YCOORD(NODEX(IEL,J)) )
END IF
C
END DO
END DO
RETURN
END
C
C
SUBROUTINE MINMAX ( MXN, NNODE, Q, QMIN, QMAX )
IMPLICIT REAL*8 ( A-H , O-Z )
DIMENSION Q(MXN)
QMIN = Q(1)
QMAX = Q(1)
DO I = 1 , NNODE
QMIN = AMIN1 ( QMIN , Q(I) )
QMAX = AMAX1 ( QMAX , Q(I) )
END DO
RETURN
END
C
C
SUBROUTINE PLTEL4 ( ND,MXE,MXN,NODEX,NE,XCOORD,YCOORD )
IMPLICIT REAL*8 ( A-H , O-Z )
DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN)
CHARACTER FILENAME*12
FILENAME = "ELEMENT.OUT"
CALL PLTLGO (FILENAME)
DO I = 1 , NE
DO J = 1 , ND-1
CALL XMOVE ( XCOORD(NODEX(I,J )),YCOORD(NODEX(I,J )) )
CALL XDRAW ( XCOORD(NODEX(I,J+1)),YCOORD(NODEX(I,J+1)) )
END DO
CALL XMOVE ( XCOORD(NODEX(I,ND )),YCOORD(NODEX(I,ND )) )
CALL XDRAW ( XCOORD(NODEX(I, 1 )),YCOORD(NODEX(I, 1 )) )
END DO
CALL PLTEXT
RETURN
END
C
C======================== GRAPHICS RUTINES =============================
SUBROUTINE PLTLGO ( FILENAME )
IMPLICIT REAL*8 ( A-H , O-Z )
CHARACTER FILENAME*12
OPEN ( 1, FILE=FILENAME, STATUS='UNKNOWN' )
RETURN
END
C
C
SUBROUTINE PLTEXT
IMPLICIT REAL*8 ( A-H , O-Z )
CLOSE (1)
RETURN
END
C
C
SUBROUTINE XMOVE ( X , Y )
IMPLICIT REAL*8 ( A-H , O-Z )
WRITE (1,*) X, Y
RETURN
END
C
C
SUBROUTINE XDRAW ( X , Y )
IMPLICIT REAL*8 ( A-H , O-Z )
WRITE (1,*) X, Y
WRITE (1,*)
RETURN
END