RMAGEN84/SRC84/BRKDWN.F90

!ipk  lsdt update nov 10 1995
      SUBROUTINE BRKDWN(NCN,NELNO)
!      SUBROUTINE BRKDWN(X,Y,VL,NCN)
      SAVE
      DOUBLE PRECISION XN,XLN,YLN,XLP,YLP
      PARAMETER (NTB=100)
!
!  Routine to subdivide quadrilaterals and triangles for plotting
!
!ipkoct93       COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ
      COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
      COMMON /PLTC/IPSAV,IFLG,XLL,YLL
      LOGICAL SWITCH
!
!      DIMENSION X(10),Y(10),VL(10)
      COMMON /BRK/ X(10),Y(10),VL(10),DL(10),VLM(10)
      DIMENSION IQ(3,8),RIX(3,8),RIY(3,8)
      DIMENSION IT(3,4),ZIX(3,4),ZIY(3,4)
      DIMENSION IST(3,3)
      DIMENSION CX(3,NTB),CY(3,NTB),VAL(3,NTB),XLC(3,NTB),YLC(3,NTB)
      DIMENSION ISPLT(3),XP(6),YP(6),VP(6),XLP(6),YLP(6)
      DATA IQ / 1, 2, 9,  2, 3, 4,  2, 4, 9,  4, 5, 9,&
                1, 9, 8,  8, 9, 6,  8, 6, 7,  9, 5, 6/
      DATA RIX/ -1.,0.,0., 0.,1.,1., 0.,1.,0., 1.,1.,0.,&
                -1.,0.,-1., -1.,0.,0., -1.,0.,-1., 0.,1.,0./
      DATA RIY/ -1.,-1.,0., -1.,-1.,0., -1.,0.,0., 0.,1.,0.,&
                -1.,0.,0., 0.,0.,1., 0.,1.,1., 0.,1.,1./
      DATA IT / 1, 2, 6,   3, 4, 2,   5, 6, 4,   2, 4, 6/
      DATA ZIX/0.,.5,0.,  1.,.5,.5,  0.,0.,.5,  .5,.5,0./
      DATA ZIY/0.,0.,.5,  0.,.5,0.,  1.,.5,.5,  0.,.5,.5/
      DATA IST/ 1,4,5,  4,2,5,  1,5,3/
!     DATA XCSQ/1.0/
!
!  Distance function squared
!
      DISTSQ(AX,AY,BX,BY)=(AX-BX)**2+(AY-BY)**2

!     do n=1,ncn
!       write(90,*) n,x(n),y(n),vl(n)
!     enddo
      IF(NCN .LT. 6) THEN
        CALL EXPND(NCN,NELNO)
      ENDIF 

      XCSQ=0.25
!
!  If NCN = 3 then copy over values
!
      IF(NCN .EQ. 3) THEN
        ITT=-1
        DO 180 L=1,3
          CX(L,1)=X(L)
          CY(L,1)=Y(L)
          VAL(L,1)=VL(L)
  180   CONTINUE
        XLC(1,1)=0.
        XLC(2,1)=1.
        XLC(3,1)=0.
        YLC(1,1)=0.
        YLC(2,1)=0.
        YLC(3,1)=0.
        NTAB=1
!
!  Subdivide quadrilateral to 2 triangles and develop list
!
      ELSEIF(NCN .EQ. 4) THEN
        ITT=0
        DO 190 I=1,3
          X(I+4)=X(I)
          Y(I+4)=Y(I)
          VL(I+4)=VL(I)
  190   CONTINUE
!
!  Pick long side for diagonal
!
        IF (DISTSQ(X(1),Y(1),X(3),Y(3)) .GT. DISTSQ(X(2),Y(2),X(4),Y(4))) THEN
!
!  Rotate if its longer
!
          DO 200 I=1,5
            X(I)=X(I+1)
            Y(I)=Y(I+1)
            VL(I)=VL(I+1)
  200     CONTINUE
        ENDIF
!
!  Now process it
!
        DO 210 L=1,3
          CX(L,1)=X(L)
          CY(L,1)=Y(L)
          VAL(L,1)=VL(L)
  210   CONTINUE
        XLC(1,1)=-1.
        XLC(2,1)=1.
        XLC(3,1)=1.
        YLC(1,1)=-1.
        YLC(2,1)=-1.
        YLC(3,1)=1.
        DO 220 L=1,3
          CX(L,2)=X(L+2)
          CY(L,2)=Y(L+2)
          VAL(L,2)=VL(L+2)
  220   CONTINUE
        XLC(1,2)=1.
        XLC(2,2)=-1.
        XLC(3,2)=-1.
        YLC(1,2)=1.
        YLC(2,2)=1.
        YLC(3,2)=-1.
        NTAB=2
!
!  Subdivide 6 node triangle to 4 triangles and develop list
!
      ELSEIF(NCN .EQ. 6) THEN
        ITT=2
!       write(90,*) (x(i),i=1,8)
        DO 300 K=1,4
          DO 280 L=1,3
            CX(L,K)=X(IT(L,K))
            CY(L,K)=Y(IT(L,K))
            VAL(L,K)=VL(IT(L,K))
            XLC(L,K)=ZIX(L,K)
            YLC(L,K)=ZIY(L,K)
  280     CONTINUE
  300   CONTINUE
        NTAB=4
!
!  Subdivide 8 node quadrilateral to 8 triangles and develop list
!
      ELSEIF(NCN .GE. 8) THEN
        IF(NCN .EQ. 8) THEN
          ITT=1
        ELSE
          ITT=0
          X9=X(9)
          Y9=Y(9)
          VL9=VL(9)
        ENDIF
        DO 310 I=1,2
          X(I+8)=X(I)
          Y(I+8)=Y(I)
          VL(I+8)=VL(I)
  310   CONTINUE
!
!  Pick long side for diagonal
!
        IF (DISTSQ(X(1),Y(1),X(5),Y(5)) .GT. &
            DISTSQ(X(3),Y(3),X(7),Y(7))) THEN
!
!  Rotate if its longer
!
          DO 320 I=1,8
            X(I)=X(I+2)
            Y(I)=Y(I+2)
            VL(I)=VL(I+2)
  320     CONTINUE
        ENDIF
!
!  Define center point
!
        IF(NCN .LT. 9) THEN
          X(9)=0.
          Y(9)=0.
          VL(9)=0.
          DO 360 I=1,8
            SH=XN(ITT,I,0.d0,0.d0)
            X(9)=X(9)+SH*X(I)
            Y(9)=Y(9)+SH*Y(I)
            VL(9)=VL(9)+SH*VL(I)
  360     CONTINUE
        ELSE
          X(9)=X9
          Y(9)=Y9
          VL(9)=VL9
        ENDIF
        DO 400 K=1,8
          DO 380 L=1,3
            CX(L,K)=X(IQ(L,K))
            CY(L,K)=Y(IQ(L,K))
            VAL(L,K)=VL(IQ(L,K))
            XLC(L,K)=RIX(L,K)
            YLC(L,K)=RIY(L,K)
  380     CONTINUE
  400   CONTINUE
        NTAB=8
      ENDIF
!
!  Start at bottom of list
!
  420 CONTINUE
      N=NTAB
!
!  Check lengths of sides and nore values
!
      ISTART=0
      ICNT=0
      IF(DISTSQ(CX(1,N),CY(1,N),CX(2,N),CY(2,N)) .GT. XCSQ) THEN
        ICNT=1
        ISPLT(1)=1
        ISTART=1
      ELSE
        ISPLT(1)=0
      ENDIF  
      IF(DISTSQ(CX(2,N),CY(2,N),CX(3,N),CY(3,N)) .GT. XCSQ) THEN
        ICNT=ICNT+1
        ISPLT(2)=1
        ISTART=2
      ELSE
        ISPLT(2)=0
      ENDIF  
      IF(DISTSQ(CX(3,N),CY(3,N),CX(1,N),CY(1,N)) .GT. XCSQ) THEN
        ICNT=ICNT+1
        ISPLT(3)=1
        ISTART=3
      ELSE
        ISPLT(3)=0
      ENDIF  
      IF(ICNT .EQ. 0) THEN
!
!  Call to plot contours for each triangle
!
        IF(IPSAV .EQ. 0) THEN
          CALL CBLOK(CX(1,N),CY(1,N),VAL(1,N))
        ELSE
          CALL CONTRD(CX(1,N),CY(1,N),VAL(1,N))
        ENDIF
        NTAB=N-1
        IF(NTAB .EQ. 0) THEN
          RETURN
        ELSE
          GO TO 420
        ENDIF
      ELSEIF(ICNT .EQ. 1) THEN
!
!  We must split the triangle into 2.  Rotate first into temporary array.
!
        IF(NTAB .GT. NTB-1) THEN
          WRITE(*,*) 'ELEMENT TABLE SIZE EXCEEDED PLOT CURTAILED'
          RETURN
        ENDIF
        DO 440 I=1,3
          J=MOD(ISTART+I-2,3)+1
          XP(I)=CX(J,N)
          YP(I)=CY(J,N)
          VP(I)=VAL(J,N)
          XLP(I)=XLC(J,N)
          YLP(I)=YLC(J,N)
  440   CONTINUE
        XLN=(XLP(1)+XLP(2))/2.
        YLN=(YLP(1)+YLP(2))/2.
        XNEW=0.
        YNEW=0.
        VNEW=0.
        DO 460 I=1,NCN
          SH=XN(ITT,I,XLN,YLN)
          XNEW=XNEW+SH*X(I)
          YNEW=YNEW+SH*Y(I)
          VNEW=VNEW+SH*VL(I)
  460   CONTINUE
        CX(1,N)=XP(1)
        CX(2,N)=XNEW
        CX(3,N)=XP(3)
        CY(1,N)=YP(1)
        CY(2,N)=YNEW
        CY(3,N)=YP(3)
        VAL(1,N)=VP(1)
        VAL(2,N)=VNEW
        VAL(3,N)=VP(3)
        XLC(1,N)=XLP(1)
        XLC(2,N)=XLN
        XLC(3,N)=XLP(3)
        YLC(1,N)=YLP(1)
        YLC(2,N)=YLN
        YLC(3,N)=YLP(3)
     
        CX(1,N+1)=XP(2)
        CX(2,N+1)=XP(3)
        CX(3,N+1)=XNEW 
        CY(1,N+1)=YP(2)
        CY(2,N+1)=YP(3)
        CY(3,N+1)=YNEW 
        VAL(1,N+1)=VP(2)
        VAL(2,N+1)=VP(3)
        VAL(3,N+1)=VNEW
        XLC(1,N+1)=XLP(2)
        XLC(2,N+1)=XLP(3)
        XLC(3,N+1)=XLN 
        YLC(1,N+1)=YLP(2)
        YLC(2,N+1)=YLP(3)
        YLC(3,N+1)=YLN 
        NTAB=N+1
      ELSEIF(ICNT .EQ. 2) THEN
        IF(NTAB .GT. NTB-2) THEN
          WRITE(*,*) 'ELEMENT TABLE SIZE EXCEEDED PLOT CURTAILED'
          RETURN
        ENDIF
!
!  We must split the triangle into 3.  Rotate first into temporary array.
!
        IF(ISTART .EQ. 3) THEN
          IF(ISPLT(1) .EQ. 1) ISTART=3
          IF(ISPLT(2) .EQ. 1) ISTART=2
        ELSE
          ISTART=1
        ENDIF
        DO 540 I=1,3
          J=MOD(ISTART+I-2,3)+1
          XP(I)=CX(J,N)
          YP(I)=CY(J,N)
          VP(I)=VAL(J,N)
          XLP(I)=XLC(J,N)
          YLP(I)=YLC(J,N)
  540   CONTINUE
        XLP(4)=(XLP(1)+XLP(2))/2.
        YLP(4)=(YLP(1)+YLP(2))/2.
        XLP(5)=(XLP(2)+XLP(3))/2.
        YLP(5)=(YLP(2)+YLP(3))/2.
        XP(4)=0.
        YP(4)=0.
        VP(4)=0.
        XP(5)=0.
        YP(5)=0.
        VP(5)=0.
        DO 560 I=1,NCN
          SH=XN(ITT,I,XLP(4),YLP(4))
          XP(4)=XP(4)+SH*X(I)
          YP(4)=YP(4)+SH*Y(I)
          VP(4)=VP(4)+SH*VL(I)
          SH=XN(ITT,I,XLP(5),YLP(5))
          XP(5)=XP(5)+SH*X(I)
          YP(5)=YP(5)+SH*Y(I)
          VP(5)=VP(5)+SH*VL(I)
  560   CONTINUE
        N=NTAB-1
        DO 600 K=1,3
          N=N+1
          DO 580 L=1,3
            CX(L,N)=XP(IST(L,K))
            CY(L,N)=YP(IST(L,K))
            VAL(L,N)=VP(IST(L,K))
            XLC(L,N)=XLP(IST(L,K))
            YLC(L,N)=YLP(IST(L,K))
  580     CONTINUE
  600   CONTINUE
        NTAB=N
      ELSEIF(ICNT .EQ. 3) THEN
        IF(NTAB .GT. NTB-3) THEN
          WRITE(*,*) 'ELEMENT TABLE SIZE EXCEEDED PLOT CURTAILED'
          RETURN
        ENDIF
!
!  We must split the triangle into 4.  Fill midsides
!
        DO 640 I=1,3
          XP(2*I-1)=CX(I,N)
          YP(2*I-1)=CY(I,N)
          VP(2*I-1)=VAL(I,N)
          XLP(2*I-1)=XLC(I,N)
          YLP(2*I-1)=YLC(I,N)
  640   CONTINUE
        XLP(2)=(XLP(1)+XLP(3))/2.
        YLP(2)=(YLP(1)+YLP(3))/2.
        XLP(4)=(XLP(3)+XLP(5))/2.
        YLP(4)=(YLP(3)+YLP(5))/2.
        XLP(6)=(XLP(5)+XLP(1))/2.
        YLP(6)=(YLP(5)+YLP(1))/2.
        XP(2)=0.
        YP(2)=0.
        VP(2)=0.
        XP(4)=0.
        YP(4)=0.
        VP(4)=0.
        XP(6)=0.
        YP(6)=0.
        VP(6)=0.
        DO 660 I=1,NCN
          SH=XN(ITT,I,XLP(2),YLP(2))
          XP(2)=XP(2)+SH*X(I)
          YP(2)=YP(2)+SH*Y(I)
          VP(2)=VP(2)+SH*VL(I)
          SH=XN(ITT,I,XLP(4),YLP(4))
          XP(4)=XP(4)+SH*X(I)
          YP(4)=YP(4)+SH*Y(I)
          VP(4)=VP(4)+SH*VL(I)
          SH=XN(ITT,I,XLP(6),YLP(6))
          XP(6)=XP(6)+SH*X(I)
          YP(6)=YP(6)+SH*Y(I)
          VP(6)=VP(6)+SH*VL(I)
  660   CONTINUE
        N=NTAB-1
        DO 700 K=1,4
          N=N+1
          DO 680 L=1,3
            CX(L,N)=XP(IT(L,K))
            CY(L,N)=YP(IT(L,K))
            VAL(L,N)=VP(IT(L,K))
            XLC(L,N)=XLP(IT(L,K))
            YLC(L,N)=YLP(IT(L,K))
  680     CONTINUE
  700   CONTINUE
        NTAB=N
      ENDIF
      GO TO 420
!
      END
      SUBROUTINE CONTRD(X,Y,V)
      SAVE
!
!  Routine to draw contours across triangle
!
      COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
      LOGICAL SWITCH
      DIMENSION X(3),Y(3),V(3),XX(2),YY(2)
!
!  Get VMIN and VMAX
!
      VMIN=MIN(V(1),V(2),V(3))
      VMAX=MAX(V(1),V(2),V(3))
!
!  Process each contour value
!
      DO 500 N=1,NUMV
!
!  Test if contour lies in range
!
        IF(CONTUR(N) .LT. VMIN) GO TO 500
        IF(CONTUR(N) .GT. VMAX) GO TO 500
!
!  Its active
!
        I=0
!
!  Look for an intercept V(1) AND V(2)
!
        IF(CONTUR(N) .GE. MIN(V(1),V(2))  &
            .AND.  CONTUR(N) .LE. MAX(V(1),V(2))) THEN
!
!  We have an intercept
!
          I=I+1
          if(v(2) .ne. v(1)) then
            FACT=(CONTUR(N)-V(1))/(V(2)-V(1))
          else
            fact=0.5
          endif
!
!  Locate point
!
          XX(I)=X(1)+FACT*(X(2)-X(1))
          YY(I)=Y(1)+FACT*(Y(2)-Y(1))
        ENDIF
!
!  Look for an intercept V(2) AND V(3)
!
        IF(CONTUR(N) .GE. MIN(V(2),V(3)) &
            .AND.  CONTUR(N) .LE. MAX(V(2),V(3))) THEN
!
!  We have an intercept
!
          I=I+1
          if(v(3) .ne. v(2)) then
            FACT=(CONTUR(N)-V(2))/(V(3)-V(2))
          else
            fact=0.5
          endif
!
!  Locate point
!
          XX(I)=X(2)+FACT*(X(3)-X(2))
          YY(I)=Y(2)+FACT*(Y(3)-Y(2))
          IF(I .EQ. 2) GO TO 450
        ENDIF
!
!  Look for an intercept V(3) AND V(1)
!
        IF(CONTUR(N) .GE. MIN(V(3),V(1))  &
            .AND.  CONTUR(N) .LE. MAX(V(3),V(1))) THEN
!
!  We have an intercept
!
          I=I+1
          if(v(1) .ne. v(3)) then
            FACT=(CONTUR(N)-V(3))/(V(1)-V(3))
          else
            fact=0.5
          endif
!
!  Locate point
!
          XX(I)=X(3)+FACT*(X(1)-X(3))
          YY(I)=Y(3)+FACT*(Y(1)-Y(3))
        ENDIF
!
!  Test for no intercept *ERROR*  
!
        IF(I .LT. 2) THEN
          WRITE(*,*) 'ERROR NO INTERCEPT NOTED, PLOT CURTAILED'
          WRITE(90,*) ' NON INTERCEPT VALUES ARE'
          WRITE(90,*) v(1),v(2),v(3),contur(n)
          RETURN
        ENDIF
!
!  Now draw line
!
  450   CONTINUE
        CALL PLOTT(XX(1),YY(1),3)
        CALL PLOTT(XX(2),YY(2),2)
!
!  Go back for next contour
!
  500 CONTINUE
!
!  We are done
!
      RETURN
      END
      SUBROUTINE CBLOK(X,Y,V)
!
!  Given a triangle (X,Y) with values V  Draw polygons of the
!  contours in CONTUR that cross the triangle
!
      DIMENSION X(3),Y(3),V(3),AX(10),AY(10)
      COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
      LOGICAL SWITCH
!
!  Sort out order for values of V
!
  200 IF(V(1) .LE. V(2)) THEN
        IF(V(3) .LT. V(2)) THEN
          VT=V(2)
          V(2)=V(3)
          V(3)=VT
          XT=X(2)
          X(2)=X(3)
          X(3)=XT
          YT=Y(2)
          Y(2)=Y(3)
          Y(3)=YT
          GO TO 200
        ENDIF
      ELSE
        VT=V(1)
        V(1)=V(2)
        V(2)=VT
        XT=X(1)
        X(1)=X(2)
        X(2)=XT
        YT=Y(1)
        Y(1)=Y(2)
        Y(2)=YT
        GO TO 200
      ENDIF
!
!  INITIALIZE
!
      IPAN12=0
      IPAN23=0
!
!  Loop on contours
!
      cjfact=1.001
      DO 900 N=1,NUMV
      nn=float(n)*cjfact
      if(numv .le. 10) nn=nn+2
!
!  Check for passing lowest contour
!
      IF(CONTUR(N) .GE. V(1)) THEN
!
!  Possible active contour
!
      IF(CONTUR(N) .LE. V(3)) THEN
!
!  Definitely active.  Get intercept on 1-3
!
        if(v(3) .ne. v(1)) then
          FACT=(CONTUR(N)-V(1))/(V(3)-V(1))
        else
          fact=0.5
        endif
!
!  Locate point
!
        XX1=X(1)+FACT*(X(3)-X(1))
        YY1=Y(1)+FACT*(Y(3)-Y(1))
        IF(CONTUR(N) .LE. V(2)) THEN
!
!  Second intercept is on 1-2
!
          IPAN12=IPAN12+1
          if(v(2) .ne. v(1)) then
            FACT=(CONTUR(N)-V(1))/(V(2)-V(1))
          else
            fact=0.5
          endif
!
!  Locate point
!
          XX2=X(1)+FACT*(X(2)-X(1))
          YY2=Y(1)+FACT*(Y(2)-Y(1))
          IF(IPAN12 .EQ. 1) THEN
!
!  This is the first contour across 1-2
!
            AX(1)=X(1)
            AX(2)=XX1
            AX(3)=XX2
            AY(1)=Y(1)
            AY(2)=YY1
            AY(3)=YY2
            XX1F=XX1
            XX2F=XX2
            YY1F=YY1
            YY2F=YY2
            CALL POLYG(AX,AY,3,NN)
          ELSE
!
!  This is a second contour line
!
            AX(1)=XX1
            AX(2)=XX2
            AX(3)=XX2F
            AX(4)=XX1F
            AY(1)=YY1
            AY(2)=YY2
            AY(3)=YY2F
            AY(4)=YY1F
            XX1F=XX1
            XX2F=XX2
            YY1F=YY1
            YY2F=YY2
            CALL POLYG(AX,AY,4,NN)
          ENDIF
        ELSE
!
!  Second intercept is on 2-3
!
          IPAN23=IPAN23+1
          if(v(3) .ne. v(2)) then
            FACT=(CONTUR(N)-V(2))/(V(3)-V(2))
          else
            fact=0.5
          endif
!
!  Locate point
!
          XX2=X(2)+FACT*(X(3)-X(2))
          YY2=Y(2)+FACT*(Y(3)-Y(2))
          IF(IPAN23 .EQ. 1) THEN
!
!  This is the first contour on 2-3
!
            IF(IPAN12 .EQ. 0) THEN
!
!  There is no previous contour across this element
!
              AX(1)=X(1)
              AX(2)=XX1
              AX(3)=XX2
              AX(4)=X(2)
              AY(1)=Y(1)
              AY(2)=YY1
              AY(3)=YY2
              AY(4)=Y(2)
              XX1F=XX1
              XX2F=XX2
              YY1F=YY1
              YY2F=YY2
              CALL POLYG(AX,AY,4,NN)
            ELSE
!
!  There is a previous contour across 1-2
!
              AX(1)=XX1
              AX(2)=XX2
              AX(3)=X(2)
              AX(4)=XX2F
              AX(5)=XX1F
              AY(1)=YY1
              AY(2)=YY2
              AY(3)=Y(2)
              AY(4)=YY2F
              AY(5)=YY1F
              XX1F=XX1
              XX2F=XX2
              YY1F=YY1
              YY2F=YY2
              CALL POLYG(AX,AY,5,NN)
            ENDIF
          ELSE
!
!  This is a second contour line on 2-3
!
            AX(1)=XX1
            AX(2)=XX2
            AX(3)=XX2F
            AX(4)=XX1F
            AY(1)=YY1
            AY(2)=YY2
            AY(3)=YY2F
            AY(4)=YY1F
            XX1F=XX1
            XX2F=XX2
            YY1F=YY1
            YY2F=YY2
            CALL POLYG(AX,AY,4,NN)
          ENDIF
        ENDIF
      ELSE
!
!  Complete drawing of contour checking to see where previous
!  contour was
!
        IF(IPAN23 .GT. 0) THEN
!
!  It was on 2-3
!
          AX(1)=X(3)
          AX(2)=XX2F
          AX(3)=XX1F
          AY(1)=Y(3)
          AY(2)=YY2F
          AY(3)=YY1F
          CALL POLYG(AX,AY,3,NN)
        ELSEIF(IPAN12 .GT. 0) THEN
!
!  It was on 1-2
!
          AX(1)=X(3)
          AX(2)=X(2)
          AX(3)=XX2F
          AX(4)=XX1F
          AY(1)=Y(3)
          AY(2)=Y(2)
          AY(3)=YY2F
          AY(4)=YY1F
          CALL POLYG(AX,AY,4,NN)
        ELSE
          AX(1)=X(3)
          AX(2)=X(2)
          AX(3)=X(1)
          AY(1)=Y(3)
          AY(2)=Y(2)
          AY(3)=Y(1)
          CALL POLYG(AX,AY,3,NN)
        ENDIF
      GO TO 905
      ENDIF
      ENDIF
  900 CONTINUE
  905 CONTINUE
      RETURN
      END
      
      SUBROUTINE EXPND(NCN,N)

      USE BLK1MOD

      INCLUDE  'TXFRM.COM'
!      INCLUDE 'PARAM.COM'
!      INCLUDE 'BLK1.COM'
!      INCLUDE 'BLKBRK.COM'
!      INCLUDE 'BFILES.I90'
!      WRITE(90,*) 'BEFORE',N,X(1),X(2),X(3),Y(1),Y(2),Y(3)
      COMMON /BRK/ X(10),Y(10),VL(10),DL(10),VLM(10)
!  expand
      DSTRTN1=1.0
      N1=NOP(N,1)
      N2=NOP(N,2)
      N3=NOP(N,3)
      x1= cord(n1,1) 
      x2= cord(n3,1) 
      y1= cord(n1,2) 
      y2= cord(n3,2) 
      eldir=atan2(y2-y1,x2-x1) 
      ALFAN1=eldir-1.5708 
      ALFAN2=ALFAN1
      ALFAN3=ALFAN1
      NCN=8
      width(n2)=(width(n1)+width(n3))/2.
      TX2=X(2)
      TY2=Y(2)      
      TX3=X(3)
      TY3=Y(3)
      VL2=VL(2)
      VL3=VL(3)
      X(6)=X(3)
      Y(6)=Y(3)
      VL(6)=VL(3)
      X(2)=X(1)
      Y(2)=Y(1)
      VL(2)=VL(1)
      VL(3)=VL(1)
      X(1)=X(2)-WIDTH(N1)*COS(ALFAN1)/(2.*TXSCAL)*DSTRTN1
      X(3)=X(2)+WIDTH(N1)*COS(ALFAN1)/(2.*TXSCAL)*DSTRTN1
      Y(1)=Y(2)-WIDTH(N1)*SIN(ALFAN1)/(2.*TXSCAL)*DSTRTN1
      Y(3)=Y(2)+WIDTH(N1)*SIN(ALFAN1)/(2.*TXSCAL)*DSTRTN1
      VL(4)=VL2
      VL(8)=VL2
      X(4)=TX2+WIDTH(N2)*COS(ALFAN2)/(2.*TXSCAL)*DSTRTN1
      X(8)=TX2-WIDTH(N2)*COS(ALFAN2)/(2.*TXSCAL)*DSTRTN1
      Y(4)=TY2+WIDTH(N2)*SIN(ALFAN2)/(2.*TXSCAL)*DSTRTN1
      Y(8)=TY2-WIDTH(N2)*SIN(ALFAN2)/(2.*TXSCAL)*DSTRTN1
      VL(5)=VL3
      VL(7)=VL3
      X(5)=TX3+WIDTH(N3)*COS(ALFAN3)/(2.*TXSCAL)*DSTRTN1
      X(7)=TX3-WIDTH(N3)*COS(ALFAN3)/(2.*TXSCAL)*DSTRTN1
      Y(5)=TY3+WIDTH(N3)*SIN(ALFAN3)/(2.*TXSCAL)*DSTRTN1
      Y(7)=TY3-WIDTH(N3)*SIN(ALFAN3)/(2.*TXSCAL)*DSTRTN1
! check areas

      aj=x(3)-x(1)
      bj=y(3)-y(1)
      ak=x(5)-x(1)
      bk=y(5)-y(1)
      a1=aj*bk-ak*bj
      if(a1 .lt. 0.) then
        tx1=x(1)
        ty1=y(1)
        x(1)=x(3)
        y(1)=y(3)
        x(3)=tx1
        y(3)=ty1

      endif
      aj=x(5)-x(1)
      bj=y(5)-y(1)
      ak=x(7)-x(1)
      bk=y(7)-y(1)
      a2=aj*bk-ak*bj
      if(a2 .lt. 0) then
        tx1=x(5)
        ty1=y(5)
        x(5)=x(7)
        y(5)=y(7)
        x(7)=tx1
        y(7)=ty1
      endif

      aj=x(4)-x(1)
      bj=y(4)-y(1)
      ak=x(8)-x(1)
      bk=y(8)-y(1)
      a1=aj*bk-ak*bj
      if(a1 .lt. 0.) then
        tx1=x(4)
        ty1=y(4)
        x(4)=x(8)
        y(4)=y(8)
        x(8)=tx1
        y(8)=ty1
      endif
      RETURN
      END