You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
857 lines
19 KiB
Fortran
857 lines
19 KiB
Fortran
!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
|
|
|