!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