!ipk last update March 6 2000 fix IMAT display bug !ipk last update Feb 22 1999 add element type option !ipk last update Jan 21 1999 add plotting of storage widths !ipk lsat update oct 23 1998 change location of label in pgrid ! !**************************************************************** ! !ipk nov97 change call SUBROUTINE PLOTOT(imz) ! ! Display grid according to switch setting ! USE WINTERACTER USE BLKMAP USE BLK1MOD USE BLK2MOD ! INCLUDE 'BLK1.COM' INCLUDE 'BFILES.I90' include 'TXFRM.COM' DIMENSION XLIN(350),YLIN(350) CHARACTER*1 IFLAG CHARACTER*80 LIND !ycw mar97 add for cross section REAL XPL(5),YPL(5) INTEGER :: iw,ih,ihandle,ient,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM common /hands/ iw,ih,ihandle,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM DATA IFIRST/0/ IF(IFIRST .EQ. 0) THEN NTTRAC=0 IFIRST=1 ENDIF HT=0.2 ! CALL CHEXIT ! if(imz .ne. 2) CALL CLSCRN ! !ipk oct97 output to backup file ! !ipk test for write to backup if(imz .eq. 1) then rewind ibak call wrtout(0) endif ! !ycw mar97 add for cross section if(LCROSS) then !! call plotcs return endif !ycw ! ! Rescale coordinates for plotting ! CALL SCLMAP !rrr IF (IPSW(8) .EQ. 1) CALL PGRID ! CALL SCLCRD !ycw mar97 add for cross section if(ICRS.ne.0) then do i=1,2 XPCS(i)=(XPCS(i)-XMIN)/PSCALE YPCS(i)=(YPCS(i)-YMIN)/PSCALE enddo do i=1,NCSNOD XCND(i)=(XCND(i)-XMIN)/PSCALE YCND(i)=(YCND(i)-YMIN)/PSCALE enddo endif !ycw PSCALE = 1. XMIN = 0. YMIN = 0. ! if(np .gt. 100000) call backc(1) ! if(ipsw(4) .eq. 1) then ! do j=1,ne ! if(ieskp(j) .eq. 0 .and. imz .ne. 2) call fillemC(j,1) ! enddo ! endif ! write(90,*) 'going to drawbk',nbkfl,iswbkfl(1) ! IF(NBKFL .GT. 0) THEN ! DO I=1,NBKFL ! IF(ISWBKFL(I) .EQ. 1) CALL DRAWBK(I,IMZ) ! IF(ISWBKFL(I) .EQ. 2) CALL DRAWBKBM(I,IMZ) ! ENDDO ! ENDIF IF(IDDSW .EQ. -1) THEN IF(NP .GT. 100000) THEN IDDSW=0 ELSE IDDSW=1 ENDIF ENDIF IF(IPSW(6) .EQ. 1 .AND. IGUNIT .EQ. 203) THEN IDDSW=0 ELSEIF(NP .LE. 100000) THEN IDDSW=1 ENDIF if(IDDSW .EQ. 0) call backc(1) if(ipsw(4) .eq. 1) then jj=1 if(nbkfl .gt. 0) jj=16 do j=1,ne if(ieskp(j) .eq. 0 .and. imz .ne. 2) call fillemC(j,jj) enddo endif IF(NBKFL .GT. 0) THEN DO I=1,NBKFL IF(ISWBKFL(I) .EQ. 1) CALL DRAWBK(I,IMZ) IF(ISWBKFL(I) .EQ. 2) CALL DRAWBKBM(I,IMZ) ENDDO ENDIF ! write(90,*) 'finished drawbk' ! ! Plot map data ! IF(IMP .NE. 0) THEN IF(IPSW(1) .EQ. 1) THEN CALL PLTMAP ENDIF ENDIF ! ! If IPSW(1) = 1 plot map or plot outline if no map ! IF(IMP .EQ. 0) THEN IF(IPSW(1) .EQ. 1) IPSW(2)=1 !ipk sep94 allow plotting of outline after map ! ELSE ! IF(IPSW(1) .EQ. 1) GO TO 10 ENDIF ! ! Plot outline of grid only ! IF(IPSW(2) .EQ. 1) THEN CALL OUTLN ! GO TO 250 ENDIF ! ! Plot nodes when IPSW(3) .EQ. 1 ! 10 CONTINUE IF(IPSW(3) .EQ. 1 .OR. IPSW(9) .EQ. 1 .OR. IPSW(14) .EQ. 1) THEN IF(NP .GT. 0) THEN IF(IPSW(3) .EQ. 1) ITP=0 IF(IPSW(14) .EQ. 1) ITP=2 IF(IPSW(9) .EQ. 1) then ITP=-1 wdmin=1.e10 wdmax=-1.e10 do j=1,np IF(INSKP(J) .EQ. 1) cycle IF(CORD(J,1) .GT. 0. .AND. CORD(J,1) .LT. HSIZE) THEN IF(CORD(J,2) .GT. 0. .AND. CORD(J,2) .LT. 7.5) THEN wdmin=min(wdmin,wd(j)) wdmax=max(wdmax,wd(j)) else cycle endif else cycle endif enddo if(abs(wdmin) .gt. abs(wdmax)) then temp=log10(abs(wdmin)) elseif(wdmin .eq. 0) then temp=2.5 else temp=log10(wdmax) endif if(temp .gt. 2.) then itp=-3 elseif(temp .gt. 1.) then itp=-4 else itp=-5 endif endif DO 15 J=1,NP ! IF(MOD(J,10) .EQ. 0) THEN ! CALL CHINT(IFLAG) ! IF(IFLAG .EQ. 'i') GO TO 250 ! ENDIF IF(INSKP(J) .EQ. 1) GO TO 15 IF(CORD(J,1) .GT. 0. .AND. CORD(J,1) .LT. HSIZE) THEN IF(CORD(J,2) .GT. 0. .AND. CORD(J,2) .LT. 7.5) THEN CALL PLTNOD(J,ITP) GO TO 15 ENDIF ENDIF INSKP(J)=1 15 CONTINUE ENDIF ENDIF ! ! Plot data points ! IF(IPSW(6) .EQ. 1) THEN IF(IGUNIT .EQ.203) THEN LENROW=NCOLS1*4 FCT=10**NSIGF raddisp=rad/txscal if(raddisp .lt. 0.01) raddisp=0.01 if(colint .eq. 0.) colint=1. CALL IGrFillPattern(4) IF(ICOLSW .EQ. 0) THEN INTH=TXSCAL*0.08*FLOAT(NSIGF+3)/CELLSIZX+1 DO J=1,NCOLS1 XCOL(J)=(CELLSIZX*(J-1)+XXORG+XS)/TXSCAL ENDDO INTV=TXSCAL*0.12/CELLSIZY+1 DO I=1,NROWS1,INTV YCOL(I)=(CELLSIZY*(NROWS1+1-I)+YYORG+YS)/TXSCAL IF(YCOL(I) .GT. 0. .AND. YCOL(I) .LT. 7.5) THEN READ(203,POS=LENROW*(I-1)+1) (VALLIN(J),J=1,NCOLS1) DO J=1,NCOLS1,INTH IF(VALLIN(J) .GT. -9000.) THEN IF(XCOL(J) .LT. 0. .AND. XCOL(J) .GT. HSIZE) CYCLE CALL PLOTT(XCOL(J),YCOL(I),3) CALL PLOTT(XCOL(J),YCOL(I),2) CALL Rblack if(nsigf .lt.1) then nsigff=1 else nsigff=nsigf endif CALL NUMBR(XCOL(J),YCOL(I),0.12,VALLIN(J),0.0,NSIGFF) CALL RBlue ENDIF ENDDO ENDIF ENDDO ELSE DO J=1,NCOLS1 XCOL(J)=(CELLSIZX*(J-1)+XXORG+XS)/TXSCAL ENDDO INTV=TXSCAL*7.5/(FLOAT(IH)*CELLSIZY)+1 DO I=1,NROWS1,INTV YCOL(I)=(CELLSIZY*(NROWS1+1-I)+YYORG+YS)/TXSCAL IF(YCOL(I) .GT. 0. .AND. YCOL(I) .LT. 7.5) THEN READ(203,POS=LENROW*(I-1)+1) (VALLIN(J),J=1,NCOLS1) DO J=1,NCOLS1,INTV IF(VALLIN(J) .GT. -9000.) THEN IF(XCOL(J) .LT. 0. .AND. XCOL(J) .GT. HSIZE) CYCLE IF(VALLIN(J) .GE. 0.) THEN NCOLN=VALLIN(J)/COLINT+0.5 ELSE NCOLN=-VALLIN(J)/COLINT-0.5 ENDIF NCOLN=MOD(NCOLN,13)+2 CALL CHANGE_COLOR(NCOLN) ! CALL IGrCircle(XCOL(J),YCOL(I),RADDISP) CALL IGrRectangle(XCOL(J)-RADDISP,YCOL(I)-RADDISP,XCOL(J)+RADDISP,YCOL(I)+RADDISP) ENDIF ENDDO ENDIF ENDDO ENDIF ELSE DO 40 J=1,MAXPTS,nmapf IF(MOD(J,100000) .EQ. 0) WRITE(155,*) J,' points processed' IF(VAL(J) .GT. -9000.) THEN X=CMAP(J,1) Y=CMAP(J,2) IF(X .GT. 0. .AND. X .LT. HSIZE) THEN IF(Y .GT. 0. .AND. Y .LT. 7.5) THEN CALL PLOTT(X,Y,3) if(icolsw .eq. 0) then CALL PLOTT(X,Y,2) CALL Rblack ! ipk mar01 ! ipk jun04 CALL NUMBR(X,Y,0.15,VAL(J)*FCT,0.0,-1) if(nsigf .lt.1) then nsigff=1 else nsigff=nsigf endif call numbr(x,y,0.12,val(j),0.0,nsigff) CALL RBlue else if(val(j) .ge. 0.) then ncoln=val(j)/colint else ncoln=-val(j)/colint endif ncoln=mod(ncoln,13)+2 call change_color(ncoln) CALL IGrCircle(X,Y,RADDISP) ! call circle(x,y,raddisp) endif ENDIF ENDIF ENDIF 40 CONTINUE ENDIF Call RBlue ! GO TO 250 ENDIF ! ! Plot existing elements ! !ipk add element type option IF(IPSW(5) .EQ. 1 .OR. IPSW(4) .EQ. 1 .or. ipsw(7) .eq. 1) THEN ! CALL PLOTT(0.,7.0,3) ! CALL PLOTT(10.,7.0,2) !IPK JAN98 IERC=imz if(ne .gt. 0) then DO 20 J=1,NE XC(J)=VOID YC(J)=VOID ! IF(MOD(J,10) .EQ. 0) THEN ! CALL CHINT(IFLAG) ! IF(IFLAG .EQ. 'i') GO TO 250 ! ENDIF IF(IESKP(J) .EQ. 0) THEN !IPK JAN98 ADD IERC IF (IMAT(J) .NE. 0) CALL PLTELM(J,IERC) ENDIF 20 CONTINUE IF(IERC .GT. 0) THEN ! call clscrn() ! WRITE(LIND,*) ' Zero node corner nodes' ! call symbl & ! & (1.1,5.5,0.25,LIND,0.0,80) ! WRITE(LIND,*) ' See MESSAGES.OUT file for details' ! call symbl & ! & (1.1,5.2,0.25,LIND,0.0,80) ! WRITE(LIND,*) ' Press enter to terminate' ! call symbl & ! & (1.1,4.9,0.25,LIND,0.0,80) ! ndig=1 ! CALL GTCHARX(IFLAG,NDIG,5.0,5.5) ! CALL QUIT_PGM() ! stop CALL WMessageBox(0,0,0,'Error in element connnection'//& CHAR(13)//'Zero corner node found'//& CHAR(13)//'See Mesgen.out for details',& 'ERROR IN ELEMENT CONNECTIONS') ENDIF endif ENDIF if(IDDSW .EQ. 0) then call backc(2) endif !ycw mar97 add for cross section if(ICRS.ne.0) then call plott(XPCS(1),YPCS(1),3) call RRED call plott(XPCS(2),YPCS(2),2) do i=1,NCSNOD xpl(1)=XCND(i)-0.04 ypl(1)=YCND(i)-0.04 xpl(2)=XCND(i)+0.04 ypl(2)=ypl(1) xpl(3)=xpl(2) ypl(3)=YCND(i)+0.04 xpl(4)=xpl(1) ypl(4)=ypl(3) xpl(5)=xpl(1) ypl(5)=ypl(1) call polyfl(xpl,ypl,5,1) enddo call RBLACK endif !ycw 250 continue IF(NTRACT .GT. 0) THEN DO KK=1,NTRACT XLIN(KK)=CORD(ITRAC(KK),1) YLIN(KK)=CORD(ITRAC(KK),2) ENDDO CALL RRED !ipk jan01 CALL THICKL CALL DASHLN(XLIN,YLIN,NTRAC,0) !ipk jan01 CALL RBLACK CALL THINL call pltnod(ITRAC(1),0) call pltnod(ITRAC(NTRACT),0) ENDIF IF (IPSW(8) .EQ. 1) CALL PGRID !IPK JAN01 IF(IPSW(10) .EQ. 1) CALL PLOTCC !ipk oct02 IF(IPSW(11) .EQ. 1) CALL PLOTCSTR !ipk oct03 IF(IPSW(12) .EQ. 1) CALL PLOTCRSS(0) if(ipsw(13) .eq. 1) call plotcrss(1) IF(INREORD .EQ. 1) THEN CALL PLOTORDS ENDIF IF(IMZ .NE. 1) THEN CALL DOPLOT(IMZ) ENDIF CALL CHEXIT RETURN END ! !**************************************************************** ! SUBROUTINE PLTNOD(J,ICOL) ! USE BLK1MOD ! INCLUDE 'BLK1.COM' ! ! Plot nodes on screen ! HT = .20 IF (CORD(J,1) .LT. VDX) RETURN X = CORD(J,1) Y = CORD(J,2) CALL PLOTT(X,Y,3) CALL PLOTT(X,Y,2) IF(ICOL .EQ. 0 .OR. ICOL .EQ. 1) THEN Y = Y+0.07 FPN = J ELSEIF(ICOL .EQ. 2) THEN Y = Y+0.07 FPN = LAY(J) IF(LAY(J) .EQ. -9999) GO TO 500 ELSE !ipk jul02 Y = Y-0.11 Y = Y+0.10 !ipk jul02 FPN=WD(J)*10. fpn=wd(j) if(icrin .eq. 23) fpn=wd1(j) ENDIF IF(IJUN(J) .NE. 0) THEN Y=Y-0.17*FLOAT(IJUN(J)-2) ENDIF IF(ICOL .LT. 1) THEN CALL RRed if(lock(j) .eq. 1) call rgreen ELSE CALL RBlack ENDIF IF(X .GT. 0. .AND. X .LT. HSIZE) THEN IF(Y .GT. 0. .AND. Y .LT. 7.5) THEN ! ipk mar01 ! ipk jul02 if(icol .lt. 0) then call numbr(x,y,0.12,fpn,0.0,-icol) else CALL NUMBR(X,Y,0.15,FPN,0.0,-1) endif ENDIF ENDIF 500 CONTINUE CALL RBlue ! END ! !**************************************************************** ! !IPK JAN98 SUBROUTINE PLTELM(J) SUBROUTINE PLTELM(J,IERC) USE BLK1MOD !ipk jan99 INCLUDE 'TXFRM.COM' INCLUDE 'BFILES.I90' !IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL DIMENSION XLIN(9),YLIN(9),BLVL(9) ! ! INCLUDE 'BLK1.COM' CHARACTER*1 IJNK CHARACTER*80 LIND ! ! Plot elements already formed ! imz=ierc ierc=0 if(NBKFL .eq. 0) then call rblue else call ryellow call rblack endif IF (IMAT(J) .EQ. 0 ) RETURN NCN = NCORN(J) ! XXC = 0. YYC = 0. NLINP=0 IESKP(J)=1 DO 15 K=1,NCN N = NOP(J,K) IF (N .EQ. 0 .AND. MOD(K,2) .EQ. 1) THEN CALL SETD(23) ! CALL CLSCRN() !IPK JAN98 WRITE(*,*) ' Zero node corner node' !IPK JAN98 WRITE(*,*) ' ELEM, NOP(ELEM,K) ' !IPK JAN98 WRITE(*,'(I5,I10,7I5)') J,(NOP(J,KK),KK=1,NCN) WRITE(90,*) ' ELEM, NOP(ELEM,K) ' WRITE(90,'(I5,I10,7I5)') J,(NOP(J,KK),KK=1,NCN) !IPK JAN98 WRITE(*,*) 'Press enter to exit' !IPK JAN98 READ(*,'(A)') IJNK !IPK JAN98 CALL Quit_Pgm !IPK JAN98 STOP IERC=IERC+1 do kk=1,8 nop(j,kk)=0 enddo imat(j)=0 RETURN ENDIF ! ! IF (N .EQ. 0 .OR. CORD(N,1) .LT. VDX) GOTO 15 IF (N .EQ. 0) GO TO 15 IF(MOD(K,2) .EQ. 1 .AND. CORD(N,1) .LT. VDX) GOTO 15 IF(CORD(N,1) .LT. VDX) THEN IF(K .EQ. NCN) THEN X=(CORD(NOP(J,K-1),1)+CORD(NOP(J,1),1))/2. Y=(CORD(NOP(J,K-1),2)+CORD(NOP(J,1),1))/2. ELSE X=(CORD(NOP(J,K-1),1)+CORD(NOP(J,K+1),1))/2. Y=(CORD(NOP(J,K-1),2)+CORD(NOP(J,K+1),1))/2. ENDIF ELSE ! X = CORD(N,1) Y = CORD(N,2) ENDIF IF(X .GT. 0. .AND. X .LT. HSIZE) THEN IF(Y .GT. 0. .AND. Y .LT. 7.5) THEN IESKP(J)=0 GO TO 16 ENDIF ENDIF 15 END DO 16 CONTINUE ! IF(IESKP(J) .EQ. 1) GO TO 26 if(ipsw(7) .eq. 1 .and. iqsw(2) .GT. 0) then IF(IQSW(2) .EQ. 1) ittmp=imat(j) IF(IQSW(2) .EQ. 2) ittmp=igrpser(j) IF(ITTMP .GT. 900 ) THEN ICCT=MOD(ITTMP+1,10)+4 ELSE icct=MOD(ittmp,10)+4 ENDIF if(imz .ne. 2) then call fillemc(j,icct) endif endif DO 25 K=1,NCN N = NOP(J,K) ! IF (N .EQ. 0) go to 25 IF (CORD(N,1) .LT. VDX) GOTO 25 ! X = CORD(N,1) Y = CORD(N,2) ! IF (NCN .NE. 5 .OR. K .LT. 5) THEN IF (MOD(K,2) .EQ. 1) THEN XXC = XXC + X YYC = YYC + Y ENDIF ENDIF NLINP=NLINP+1 ! XLIN(NLINP)=X YLIN(NLINP)=Y BLVL(NLINP)=WD(N) IF (K .EQ. 1) THEN X1 = X Y1 = Y ENDIF 25 END DO IF(NCN .GT. 5) THEN NLINP=NLINP+1 XLIN(NLINP)=X1 YLIN(NLINP)=Y1 BLVL(NLINP)=WD(NOP(J,1)) ENDIF if(i3dview .eq. 1) then do k=1,nlinp YLIN(K)=YLIN(K)+(BLVL(K)-VRTORIG)*COS(VANG/57.29578)/VRTSCAL enddo endif !ipkoct93 if(ipsw(4) .eq. 1) then if(ncn .eq. 8 .or. imat(j) .lt. 901) then CALL DASHLN(XLIN,YLIN,NLINP,0) ! write(155,'(2i6,24f12.3)') j,ncn,(xlin(k),ylin(k),blvl(k),k=1,ncn) endif endif ! IF(IMAT(J) .LT. 901 .AND. IPSW(4) .EQ. 1) ! + CALL DASHLN(XLIN,YLIN,NLINP,0) !ipkoct93 ! ! Plot elem number at center if IPSW(5) = 1 ! CALL RCyan IF (NCN .EQ. 3 .OR. NCN .EQ. 5) NCN = 4 XC(J) = 2.*XXC/NCN YC(J) = 2.*YYC/NCN ! IF(IMAT(J) .GT. 900 ) THEN IF(IMAT(J) .GT. 900 .and. ncorn(j) .ne. 8) THEN CALL RBlue RETURN ENDIF !ipk feb99 add element type option IF(IPSW(5) .EQ. 1 .or. ipsw(7) .eq. 1) THEN HT = .20 if(ipsw(5) .eq. 1) then FPN = J !ipk mar00 fix imat display bug elseif((iqsw(1) .gt. 0) .or. (iqsw(1) .eq. 0 .and. iqsw(2) .eq. 0) ) then CALL RBLACK if(iqsw(1) .eq. 1) fpn=imat(j) if(iqsw(1) .eq. 2) fpn=igrpser(j) ! elseif(iqsw(2) .eq. 1) then ! CALL RBLACK ! fpn=imat(j) else go to 30 endif IF(XC(J) .GT. 0. .AND. XC(J) .LT. HSIZE) THEN IF(YC(J) .GT. 0. .AND. YC(J) .LT. 7.5) THEN !ipkoct93 ! IF(IMAT(J) .LT. 901) CALL NUMBR(XC(J),YC(J),HT,FPN,0.0,-1) ! ipk mar01 !ipk jun02 xxc=xc(j) yyc=yc(j) CALL NUMBR(XXC,YYC,0.15,FPN,0.0,-1) ENDIF ! elseif(iqsw(2) .eq. 1) then ! CALL RBLACK ! fpn=imat(j) endif 30 continue ENDIF !ipk jan99 add plot of 1-d element widths if(ncorn(j) .eq. 3 .or. ncorn(j) .eq. 5) then ncn=3 n1=nop(j,1) n2=nop(j,3) ! !...... first for widths IF(IPW1 .EQ. 1) THEN wd11=width(n1)/txscal wd2=width(n2)/txscal ELSE IF(NRIVCR1(N1) .EQ. 0 .AND. NRIVCR2(N1) .EQ. 0) RETURN IF(NRIVCR1(N2) .EQ. 0 .AND. NRIVCR2(N2) .EQ. 0) RETURN BT1= & CRSDAT(NRIVCR1(N1),1,1)*WTRIVCR1(N1)+ & CRSDAT(NRIVCR2(N1),1,1)*WTRIVCR2(N1) BT2= & CRSDAT(NRIVCR1(N2),1,1)*WTRIVCR1(N2)+ & CRSDAT(NRIVCR2(N2),1,1)*WTRIVCR2(N2) H1=WIDEL-BT1 H2=WIDEL-BT2 CALL INTERPWLV(N1,H1,AR1,WR1,DWR1) CALL INTERPWLV(N2,H2,AR2,WR2,DWR2) WIDTH(N1)=WR1 WIDTH(N2)=WR2 IF(IPW1 .EQ. 2) THEN WD11=WR1*WIDSCL/TXSCAL WD2=WR2*WIDSCL/TXSCAL ELSE WD11=AR1*WIDSCL/TXSCAL WD2=AR2*WIDSCL/TXSCAL ENDIF ENDIF if(wd11 .gt. 0. .and. wd2 .gt. 0.) then x1= cord(n1,1) x2= cord(n2,1) y1= cord(n1,2) y2= cord(n2,2) eldir=atan2(y2-y1,x2-x1) elnorm=eldir-1.5708 xlin(1)=x1+cos(elnorm)*wd11/2. xlin(5)=xlin(1) xlin(4)=x1-cos(elnorm)*wd11/2. xlin(2)=x2+cos(elnorm)*wd2/2. xlin(3)=x2-cos(elnorm)*wd2/2. ylin(1)=y1+sin(elnorm)*wd11/2. ylin(5)=ylin(1) ylin(4)=y1-sin(elnorm)*wd11/2. ylin(2)=y2+sin(elnorm)*wd2/2. ylin(3)=y2-sin(elnorm)*wd2/2. call dashln(xlin,ylin,5,0) endif !...... then for storage widths wd11=(wids(n1)+width(n1))/txscal wd2=(wids(n2)+width(n2))/txscal if(wids(n1) .gt. 0. .and. wids(n2) .gt. 0.) then x1= cord(n1,1) x2= cord(n2,1) y1= cord(n1,2) y2= cord(n2,2) eldir=atan2(y2-y1,x2-x1) elnorm=eldir-1.5708 xlin(1)=x1+cos(elnorm)*wd11/2. xlin(5)=xlin(1) xlin(4)=x1-cos(elnorm)*wd11/2. xlin(2)=x2+cos(elnorm)*wd2/2. xlin(3)=x2-cos(elnorm)*wd2/2. ylin(1)=y1+sin(elnorm)*wd11/2. ylin(5)=ylin(1) ylin(4)=y1-sin(elnorm)*wd11/2. ylin(2)=y2+sin(elnorm)*wd2/2. ylin(3)=y2-sin(elnorm)*wd2/2. call dashln(xlin,ylin,5,1) endif endif CALL RBlue 26 CONTINUE ! RETURN END ! !**************************************************************** ! SUBROUTINE PLTMAP ! USE BLKMAP USE BLK1MOD ! INCLUDE 'BLK1.COM' ! ! Plot map of input data ! ! Determine how long each line is ! JS=1 ! K=0 CALL RCyan DO 20 J=1,MAXPTS MLEN=J-JS ! write(90,*) 'j,mlen',j,mlen,cmap(j,1),k+1,lintyp(k+1),vdx ! write(123,*) 'j,mlen',j,mlen,cmap(j,1),k+1,lintyp(k+1),vdx IF(XMAP(J) .LE. VDX .or. j .eq. maxpts) THEN if(j .eq. maxpts .and. xmap(j) .gt. vdx) mlen=mlen+1 ! ! Now draw it. ! K=K+1 IF(MLEN .GT. 1) THEN LTP=LINTYP(K) !ipk oct96 if(icolon(ltp+1) .eq. 1) then IF(LTP .NE. 2) THEN !ipk oct96 IF(LTP .LT. 2) THEN CALL RRed ! write(90,*) 'at nwpen ltp',ltp IF(LTP .GT. 0) CALL NWPEN(2*LTP+1) IF(LTP .GT. 2) LTP=0 CALL DBDASHLN(cmap(js,1),cmap(js,2),MLEN,LTP) ENDIF ENDIF ENDIF IF(MLEN .EQ. 0 .AND. LINTYP(K) .EQ. -999) GO TO 30 JS=J+1 ENDIF 20 CONTINUE 30 CONTINUE CALL RBlue RETURN ! END ! !*********************************************************************** ! SUBROUTINE SCLMAP ! ! Scale map coordinates for plotting ! Keep track and update information for mapping ! screen coordinates back to user coordinates ! USE BLKMAP USE BLK1MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'TXFRM.COM' !IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL ! !ipk may94 moved to blk1.com DATA XREF,YREF / 0.0, 0.0 / ! DO 10 J=1,MAXPTS IF (CMAP(J,1) .LT. VDX) GOTO 10 CMAP(J,1) = (CMAP(J,1)-XMIN)/PSCALE CMAP(J,2) = (CMAP(J,2)-YMIN)/PSCALE 10 END DO ! XREF = (XREF-XMIN)/PSCALE YREF = (YREF-YMIN)/PSCALE IF(IASPCT .EQ. 1) THEN VRTSCAL=VRTSCAL*PSCALE ENDIF TXSCAL = TXSCAL*PSCALE XS = XREF*TXSCAL YS = YREF*TXSCAL write(90,*) ' The line that follows gives the values used for a te& &mporary origin and scale' write(90,6000) xs,ys,txscal 6000 format(3f15.4) ! RETURN END ! !*********************************************************************** ! SUBROUTINE SCLCRD ! ! Scale coordinates for plotting ! Keep track and update information for mapping ! screen coordinates back to user coordinates ! USE BLK1MOD ! INCLUDE 'BLK1.COM' ! REAL*8 ANGPT,ANGNEW,DRAD,DVANG,DVANGOLD DATA PI/3.14159265/,ITIME/0/,DRAD/57.29577957855/ IF(ITIME .EQ. 0) THEN VANGOLD=90. VANG=90. HANG=0. HANGOLD=0. ! DRAD=180./PI ITIME=1 ENDIF DVANG=VANG DVANGOLD=VANGOLD ! ! ROTATE BACK IF NEEDED IF((HANGOLD .EQ. HANG) .AND. (VANGOLD .EQ. VANG)) GO TO 5 IF(HANGOLD .NE. 0. .OR. VANGOLD .NE. 90.) THEN IF(NP .GT. 0) THEN DO J=1,NP IF (CORD(J,1) .GE. VDX) THEN IF(VANGOLD .LT. 90.) THEN CORD(J,2)=4.+(CORD(J,2)-4.)/DSIN(DVANGOLD/DRAD) ENDIF ANGPT=DATAN2D(CORD(J,2)-4,CORD(J,1)-5.) VLEN=SQRT((CORD(J,1)-5.)**2+(CORD(J,2)-4.)**2) ANGNEW=ANGPT+HANGOLD ! IF(J .EQ. 1) THEN ! WRITE(90,*) 'ROTBACK',ANGPT,VLEN,ANGNEW,CORD(J,1),CORD(J,2) ! ENDIF CORD(J,1)=5.+VLEN*DCOS(ANGNEW/DRAD) CORD(J,2)=4.+VLEN*DSIN(ANGNEW/DRAD) ! IF(J .EQ. 1) THEN ! WRITE(90,*) CORD(J,1),CORD(J,2) ! ENDIF ENDIF ENDDO ENDIF ENDIF 5 CONTINUE IF(NP .GT. 0) THEN DO 10 J=1,NP IF (CORD(J,1) .LT. VDX) GOTO 10 CORD(J,1) = (CORD(J,1)-XMIN)/PSCALE CORD(J,2) = (CORD(J,2)-YMIN)/PSCALE 10 CONTINUE ENDIF ! ! ROTATE IF NEEDED IF((HANGOLD .EQ. HANG) .AND. (VANGOLD .EQ. VANG)) GO TO 15 IF(HANG .NE. 0 .OR. VANG .LT. 90.) THEN IF(NP .GT. 0) THEN DO J=1,NP IF (CORD(J,1) .GE. VDX) THEN ANGPT=DATAN2D(CORD(J,2)-4,CORD(J,1)-5.) VLEN=SQRT((CORD(J,1)-5.)**2+(CORD(J,2)-4.)**2) ANGNEW=ANGPT-HANG ! IF(J .EQ. 1) THEN ! WRITE(90,*) 'ROT',ANGPT,VLEN,ANGNEW,CORD(J,1),CORD(J,2) ! ENDIF CORD(J,1)=5.+VLEN*DCOS(ANGNEW/DRAD) CORD(J,2)=4.+VLEN*DSIN(ANGNEW/DRAD) IF(VANG .LT. 90.) THEN CORD(J,2)=4.+(CORD(J,2)-4.)*DSIN(DVANG/DRAD) ENDIF ! IF(J .EQ. 1) THEN ! WRITE(90,*) CORD(J,1),CORD(J,2) ! ENDIF ENDIF ENDDO ENDIF ENDIF HANGOLD=HANG VANGOLD=VANG 15 CONTINUE RETURN ! END SUBROUTINE BOX(HEAD,NSIZ) ! ! Routine to draw NSIZ header boxes at top of page with the HEAD label ! CHARACTER*8 HEAD(*) XSY=0. XLMT=FLOAT(NSIZ) DO 200 N=1,NSIZ CALL SYMBL(XSY,7.65,0.20,HEAD(N),0.0, 8) XSY=XSY+1.0 200 CONTINUE ! ! Draw box around selections ! CALL PLOTT(0.0,7.0,3) CALL PLOTT(XLMT,7.0,2) CALL PLOTT(XLMT,7.495,2) CALL PLOTT(0.0,7.495,2) CALL PLOTT(0.0,7.0,2) XPT=0. DO 205 I=1,NSIZ XPT=XPT+1.0 CALL PLOTT(XPT,7.0,3) CALL PLOTT(XPT,7.495,2) 205 CONTINUE RETURN END SUBROUTINE BOXR(NBOX) SAVE ! ! Routine to draw header box at top right of page with the HEAD label ! CHARACTER*24 HEAD CHARACTER*16 HEAD1 CHARACTER*24 HEAD2 DIMENSION X(5),Y(5) DATA HEAD /' (z)oom r(d)raw (q)uit '/ DATA HEAD1 /' r(d)raw (q)uit '/ DATA HEAD2 /' (n)ext (z)oom (q)uit '/ ! ! Draw box around selections ! NBX=IABS(NBOX) XLEFT=10-NBX Y(1)=7.5 Y(2)=7.5 Y(3)=7.995 Y(4)=7.995 Y(5)=7.5 ! CALL PLOTT(XLEFT,7.0,3) ! CALL PLOTT(10.0,7.0,2) ! CALL PLOTT(10.0,7.495,2) ! CALL PLOTT(XLEFT,7.495,2) ! CALL PLOTT(XLEFT,7.0,2) ! IF(NBOX .GT. 1) THEN DO 200 K=1,NBX X(1)=XLEFT X(4)=XLEFT X(5)=XLEFT XLEFT=XLEFT+1.0 X(2)=XLEFT X(3)=XLEFT IBLK=4 CALL POLYFL(X,Y,5,IBLK) CALL RBLACK CALL PLOTT(X(1),Y(1),3) CALL PLOTT(X(2),Y(2),2) CALL PLOTT(X(3),Y(3),2) CALL PLOTT(X(4),Y(4),2) CALL PLOTT(X(1),Y(1),2) ! DO 200 K=1,NBOX-1 ! XLEFT=XLEFT+1. ! CALL PLOTT(XLEFT,7.0,3) ! CALL PLOTT(XLEFT,7.495,2) 200 END DO ! ENDIF ! ! Establish label ! IF(NBOX .EQ. 3) THEN CALL SYMBL(7.0,7.65,0.20,HEAD,0.0,24) ELSEIF(NBOX .EQ. -3) THEN CALL SYMBL(7.0,7.65,0.20,HEAD2,0.0,24) ELSEIF(NBOX .EQ. 2) THEN CALL SYMBL(8.0,7.65,0.20,HEAD1,0.0,16) ENDIF RETURN END ! ! SUBROUTINE OUTLN !- !......OUTLN DRAWS BOUNDARIES FOR THE SYSTEM !- USE BLK1MOD ! INCLUDE 'BLK1.COM' ! ! INTEGER*2 MSN ! COMMON /MID/ MSN(MAXP) ! DATA IFIRST / 1 / !- !- ! DATA MAXB/MAXE/ YMAXX = 7.50 !- !-.....PLOT BOUNDARY OUTLINE..... !- ! 100 DO 110 J=1,MAXB ! NBP(J) = 0 ! 110 CONTINUE ! IF (IFIRST .EQ. 1) GOTO 185 IFIRST = 0 ! NPTS=-1 ! READ(5,5020) NPTS ! 5020 FORMAT( 16I5 ) IF( NPTS .EQ. 0 ) RETURN 185 CONTINUE DO 186 I=1,NP 186 MSN(I) = 0 DO 187 J=1,NE IF(IESKP(J) .NE. 0) GO TO 187 IF (IMAT(J) .LE. 0) GOTO 187 IF (IMAT(J) .GT. 900) GO TO 187 NCN = 6 IF (NOP(J,7) .NE. 0) NCN = 8 IF (NOP(J,6) .EQ. 0) NCN=3 DO 188 K=2,NCN,2 N = NOP(J,K) if(n .gt. 0) then MSN(N) = MSN(N) + 1 endif 188 CONTINUE 187 END DO DO 195 J = 1, NE IF(IESKP(J) .NE. 0) GO TO 195 IF(IMAT(J) .LE. 0) GO TO 195 !ipkoct93 ! IF(IMAT(J) .GT. 900) GO TO 195 IF(IMAT(J) .GT. 900 .and. nop(j,7) .eq. 0) GO TO 195 NCN = 6 IF (NOP(J,7) .NE. 0) NCN = 8 IF (NOP(J,6) .EQ. 0) NCN=3 DO 194 K = 2,NCN , 2 L=NOP(J,K) IF(L .EQ. 0) GO TO 194 IF(MSN(L) .EQ. 1) THEN N1 = NOP(J,K-1) N2 = NOP(J,K) N3 = MOD(K+1,NCN) IF(N3 .EQ. 0) N3=NCN N3 = NOP(J,N3) X1 = CORD(N1,1) Y1 = CORD(N1,2) X2 = CORD(N2,1) Y2 = CORD(N2,2) X3 = CORD(N3,1) Y3 = CORD(N3,2) CALL FIT(X1,Y1,X2,Y2,X3,Y3) ENDIF 194 CONTINUE 195 END DO RETURN END SUBROUTINE AROHD(XPAGE,YPAGE,XTIP,YTIP,AHLEN,AHWID,ICODE) !*********************************** .....AROHD..... SAVE ! IF(AHWID.LE.0.001) AHWID=AHLEN I1=ICODE/10+3 IF(I1.NE.3) I1=2 KK=MOD(ICODE,10) I2=2 I3=2 I4=2 IF(KK.EQ.2) GO TO 10 IF(KK.NE.4) GO TO 20 I3=3 GO TO 10 20 IF(KK.NE.5) GO TO 30 I2=3 I3=3 GO TO 10 30 IF(KK.NE.8) GO TO 10 I2=3 I3=3 I4=4 10 CONTINUE CALL PLOTT(XPAGE,YPAGE,3) CALL PLOTT(XTIP,YTIP,I1) TX=XTIP-XPAGE TY=YTIP-YPAGE XLEN=SQRT(TX**2+TY**2) IF(XLEN .GT. 0.001) GO TO 200 XLEN=0.001 IF(ABS(TX) .LT. 0.001) TX=SIGN(0.001,TX) IF(ABS(TY) .LT. 0.001) TY=SIGN(0.001,TY) 200 CONTINUE TA=AHLEN/XLEN XX=XTIP-TA*TX YY=YTIP-TA*TY AH=(AHWID/2.)**2 DY=SQRT(AH*TX**2/(TX**2+TY**2)) DY = SIGN(DY,TX) DX=SQRT(AH*TY**2/(TX**2+TY**2)) DX = SIGN(DX,TY) X1=XX+DX X2=XX-DX Y1=YY+DY Y2=YY-DY CALL PLOTT(X2,Y1,I2) CALL PLOTT(X1,Y2,I3) CALL PLOTT(XTIP,YTIP,I4) RETURN END ! !$$$ AUG 1987 ! SUBROUTINE TEST(X,Y,IG) ! !...... Routine to that plot is on paper ! ! SAVE ! ! ! IG=0 ! IF(X .LT. 0. ) RETURN ! IF(X .GT. 10.) RETURN ! IF(Y .LT. 0. ) RETURN ! IF(Y .GT. 7.0) RETURN ! IG=1 ! RETURN ! END ! SUBROUTINE FIT(X1,Y1,X2,Y2,X3,Y3) SAVE ! INTEGER I2,I3,IG common /tek/ itek DATA I2/2/,I3/3/ NPTS = 7 DS = 1.0/FLOAT(NPTS) S = 0.0 ! IG=0 ! CALL TEST(X1,Y1,IT) ! IF(IT .GT. 0) THEN CALL PLOTT(X1,Y1,I3) IG=I3 ! ENDIF dx3 = x1-x3 dx2 = x1-x2 dy3 = y1-y3 dy2 = y1-y2 if (abs(dx2) .le. 1.E-8) dx2 = 1.E-8 if (abs(dx3) .le. 2.E-8) dx3 = 2.E-8 ! call test(x3,y3,itt) if (abs(dy3/dx3 - dy2/dx2) .le. abs(.01*dy2/dx2)) then ! .and. ! + itt .gt. 0 .and. it .gt. 0) then call plott(x3,y3,i2) else DO 100 J = 1, NPTS S = S + DS XN1 = 1.0-3.0*S+2.0*S**2 XN2 = 4.0*S*(1.0-S) XN3 = S*(2.0*S-1.0) X= XN1*X1 + XN2*X2 + XN3*X3 Y = XN1*Y1 + XN2*Y2 + XN3*Y3 ! CALL TEST(X,Y,IT) ! IF(IT .GT. 0) THEN ! IF(IG .EQ. 0) THEN ! IG=I3 ! ELSE IG=I2 ! ENDIF CALL PLOTT(X,Y,IG) ! ELSE ! IG=0 ! ENDIF 100 END DO endif RETURN END ! !**************************************************************** ! SUBROUTINE PGRID ! ! Form rectangular grid for guide lines by filling map arrays ! USE BLK1MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'TXFRM.COM' !IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL ! DIMENSION XG(2),YG(2) ! DATA IFIRST / 1 / ! IF (IFIRST .EQ. 1) THEN DX = 10. DY = 10. X0 = -100. !ipk sep94 update to 7.5 size Y0 = -70. Y0 = -75. X9 = HSIZE*10. !ipk sep94 update to 7.5 size Y9 = 70. Y9 = 75. ! IF (XMIN .GT. -VDX) THEN XMIN = -100. XMAX = -XMIN IPSW(8) = 1 ENDIF IF (YMIN .GT. -VDX) THEN !ipk sep94 update to 7.5 size YMIN = -70. YMIN = -75. YMAX = -YMIN IPSW(8) = 1 ENDIF ! IFIRST = 0 RETURN ! ELSE ! XDIF = TXSCAL * 10.5 XDIF = TXSCAL * HSIZE*1.05 IXDIF = IFIX( LOG10(XDIF) ) XRANGE = 10**IXDIF XFAC = XDIF/XRANGE DX = XRANGE/10. IF ( XFAC .GE. 5.) THEN DX = 5.*DX ELSEIF (XFAC .GE. 2.) THEN DX = 2.*DX ENDIF ! X0 = -NINT(XS/DX - .5) * DX - DX X9 = X0 + XDIF ! DY = DX !ipk sep94 update to 7.5 scale YDIF = .70*XDIF YDIF = .75*XDIF Y0 = -NINT(YS/DY -.5) * DY - DY Y9 = Y0 + YDIF ENDIF ! ! vertical-grid lines LTP = 0 MLEN = 2 HT = .18 ! DO 10 CX = X0,X9, DX XG(1) = (CX + XS)/TXSCAL YG(1) = (Y0 + YS)/TXSCAL XG(2) = XG(1) YG(2) = (Y9 + YS)/TXSCAL CALL NWPEN(8) CALL DASHLN(XG,YG,MLEN,LTP) ! FPN = CX IF (AMOD(FPN,1.) .EQ. 0. .OR. ABS(FPN) .LT. 0.01) THEN IPLC = -1 ELSE IPLC = 1 ENDIF X = XG(1) ! Y = YG(1) + .02 !ipk oct98 change y location Y = .20 IF ( (X .GT. 0. .AND. X .LT. HSIZE) .AND. & & (Y .GT. 0. .AND. Y .LT. 7.5) ) THEN !ipk sep94 change colour CALL NWPEN(12) CALL NWPEN(8) ! ipk mar01 CALL NUMBR(X,Y,0.15,FPN,0.0,IPLC) ENDIF 10 END DO ! ! horizontal-grid lines DO 20 CY = Y0,Y9, DY XG(1) = (X0 + XS)/TXSCAL YG(1) = (CY + YS)/TXSCAL XG(2) = (X9 + XS)/TXSCAL YG(2) = YG(1) CALL NWPEN(8) CALL DASHLN(XG,YG,MLEN,LTP) ! FPN = CY IF (AMOD(FPN,1.) .EQ. 0. .OR. ABS(FPN) .LT. 0.01) THEN IPLC = -1 ELSE IPLC = 1 ENDIF ! X = XG(1) X = .02 Y = YG(1) IF ( (X .GT. 0. .AND. X .LT. HSIZE) .AND. & & (Y .GT. 0. .AND. Y .LT. 7.5) ) THEN !ipk sep94 change color CALL NWPEN(12) CALL NWPEN(8) ! ipk mar01 CALL NUMBR(X,Y,0.15,FPN,0.0,IPLC) ENDIF 20 END DO ! CALL RBlue ! END SUBROUTINE RESCAL ! ! Scale for plotting ! ! USE BLKMAP USE BLK1MOD ! INCLUDE 'BLK1.COM' INCLUDE 'TXFRM.COM' INCLUDE 'BFILES.I90' !IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL ! VDX = - 1.0E+10 XREF=0. YREF=0. ! ! Reset map coordinates to original scale ! IF(MAXPTS .GT. 0) THEN DO J=1,MAXPTS IF(CMAP(J,1) .GE. VDX) THEN CMAP(J,1)=TXSCAL*CMAP(J,1) - XS CMAP(J,2)=TXSCAL*CMAP(J,2) - YS ENDIF ENDDO ENDIF ! ! Reset nodal coordinates ! IF(NP .GT. 0) THEN DO J=1,NP CORD(J,1) = XUSR(J) CORD(J,2) = YUSR(J) ENDDO ENDIF !ycw mar97 add for cross section if(ICRS.ne.0) then do i=1,2 XPCS(i)=XPCS(i)*TXSCAL - XS YPCS(i)=YPCS(i)*TXSCAL - YS enddo do i=1,NCSNOD XCND(i)=XCND(i)*TXSCAL - XS YCND(i)=YCND(i)*TXSCAL - YS enddo endif !ycw ! ! Reset controlling scales ! TXSCAL = 1. XS=0. YS=0. XMIN = 1.E+20 XMAX = -XMIN YMIN = 1.E+20 YMAX = -YMIN IF(IMP .GT. 0) THEN ! ! Find max and min ! ! DO J=1,MAXPTS IF (CMAP(J,1) .GT. VDX) THEN IF (CMAP(J,1) .LT. XMIN) XMIN = CMAP(J,1) IF (CMAP(J,1) .GT. XMAX) XMAX = CMAP(J,1) IF (CMAP(J,2) .LT. YMIN) YMIN = CMAP(J,2) IF (CMAP(J,2) .GT. YMAX) YMAX = CMAP(J,2) ENDIF ENDDO ENDIF ! IF(NP .GT. 0) THEN DO J=1,NP IF (CORD(J,1) .GT. VDX) THEN INSKP(J)=0 IF (CORD(J,1) .LT. XMIN) XMIN = CORD(J,1) IF (CORD(J,1) .GT. XMAX) XMAX = CORD(J,1) IF (CORD(J,2) .LT. YMIN) YMIN = CORD(J,2) IF (CORD(J,2) .GT. YMAX) YMAX = CORD(J,2) ENDIF ENDDO ENDIF IF(NE .GT. 0) THEN DO J=1,NE IF(NOP(J,1) .NE. 0) THEN IESKP(J)=0 ENDIF ENDDO ENDIF ! ! DO J=1,NBKFL XMAX=MAX(XMAX,BFMINMAX(J,1),BFMINMAX(J,3)) XMIN=MIN(XMIN,BFMINMAX(J,1),BFMINMAX(J,3)) YMAX=MAX(YMAX,BFMINMAX(J,2),BFMINMAX(J,4)) YMIN=MIN(YMIN,BFMINMAX(J,2),BFMINMAX(J,4)) ENDDO AMAP=(XMAX-XMIN)*(YMAX-YMIN) XSCALE = (XMAX-XMIN)/(hsize-0.5) YSCALE = (YMAX-YMIN)/6.5 PSCALE = MAX(XSCALE,YSCALE) ! XAVE = (XMIN + XMAX) /2.0 YAVE = (YMIN + YMAX) /2.0 XMIN = XAVE - hsize/2.*PSCALE YMIN = YAVE - 3.5*PSCALE XMAX = XAVE + (hsize-0.5)/2.*PSCALE YMAX = YAVE + 3.25*PSCALE ! ! Plot all data ! CALL PLOTSV(0) !ipk nov97 add (0) CALL PLOTOT(0) RETURN END !IPK JAN01 NEW ROUTINE SUBROUTINE PLOTCC USE BLK1MOD use blk2mod ! INCLUDE 'BLK1.COM' DIMENSION XLIN(350),YLIN(350) IF(NCLM .GT. 0) THEN !Process each line CALL RBLUE DO NCLL=1,NCLM WRITE(90,*) 'PLOTR1-1130 NCLL,NCLM',NCLL,NCLM DO KK=1,350 IF(ICCLN(NCLL,KK) .NE. 0) THEN IF(KK .EQ. 1) THEN X=CORD(ICCLN(NCLL,KK),1)+0.1 Y=CORD(ICCLN(NCLL,KK),2)+0.1 IF(X .GT. 0. .AND. X .LT. HSIZE) THEN IF(Y .GT. 0. .AND. Y .LT. 7.5) THEN FPN=NCLL ! ipk mar01 CALL NUMBR(X,Y,0.2,FPN,0.0,-1) ENDIF ENDIF ENDIF XLIN(KK)=CORD(ICCLN(NCLL,KK),1) YLIN(KK)=CORD(ICCLN(NCLL,KK),2) ELSE if(kk .eq. 1) GO TO 510 NTRAC=KK-1 X=CORD(ICCLN(NCLL,KK-1),1)+0.1 Y=CORD(ICCLN(NCLL,KK-1),2)+0.1 IF(X .GT. 0. .AND. X .LT. HSIZE) THEN IF(Y .GT. 0. .AND. Y .LT. 7.5) THEN FPN=NCLL ! ipk mar01 CALL NUMBR(X,Y,0.2,FPN,0.0,-1) ENDIF ENDIF if(ntrac .eq. 1) then call IGrCharSize(0.5,0.5) call IGrMarker(x-0.1,y-0.1,14) call IGrCharSize(1.0,1.0) endif ! ! Draw along line ! IF(NTRAC .GT. 1) THEN CALL THICKL CALL DASHLN(XLIN,YLIN,NTRAC,0) CALL THINL ENDIF GO TO 400 ENDIF 359 CONTINUE ENDDO 400 CONTINUE IF(NTRAC .EQ. 1) THEN NODL=ICCLN(NCLL,1) DO N=1,NE IF(IMAT(N) .LT. 900 .AND. IMAT(N) .GT. 0) THEN IF(NCORN(N) .EQ. 5 .OR. NCORN(N) .EQ. 3) THEN IF(NOP(N,1) .EQ. NODL) THEN DIRX=CORD(NOP(N,3),1)-CORD(NOP(N,1),1) DIRY=CORD(NOP(N,3),2)-CORD(NOP(N,1),2) GO TO 420 ELSEIF(NOP(N,3) .EQ. NODL) THEN DIRX=CORD(NOP(N,1),1)-CORD(NOP(N,3),1) DIRY=CORD(NOP(N,1),2)-CORD(NOP(N,3),2) GO TO 420 ENDIF ENDIF ENDIF ENDDO 420 DIR=ATAN2(DIRX,-DIRY) D1=CORD(NODL,1) D2=CORD(NODL,2) ELSE ! Plot arrows on continuity line DIRX=CORD(ICCLN(NCLL,1),1)-CORD(ICCLN(NCLL,NTRAC),1) DIRY=CORD(ICCLN(NCLL,1),2)-CORD(ICCLN(NCLL,NTRAC),2) IF(DIRX .EQ. 0. .AND. DIRY .EQ. 0.) THEN DIR=0. ELSE DIR=ATAN2(DIRX,-DIRY) D1=(CORD(ICCLN(NCLL,1),1)+CORD(ICCLN(NCLL,NTRAC),1))/2. D2=(CORD(ICCLN(NCLL,1),2)+CORD(ICCLN(NCLL,NTRAC),2))/2. ENDIF ENDIF DIR1=DIR+2.35619 DIR2=DIR-2.35619 DE1=D1+0.4*COS(DIR) DE2=D2+0.4*SIN(DIR) DEA1=DE1+0.1*COS(DIR1) DEA2=DE2+0.1*SIN(DIR1) DEB1=DE1+0.1*COS(DIR2) DEB2=DE2+0.1*SIN(DIR2) CALL RBLUE CALL PLOTT(D1,D2,3) CALL PLOTT(DE1,DE2,2) CALL PLOTT(DEA1,DEA2,2) CALL PLOTT(DE1,DE2,3) CALL PLOTT(DEB1,DEB2,2) CALL RBLUE 510 CONTINUE ENDDO ENDIF RETURN END SUBROUTINE PLOTCSTR USE BLK1MOD ! INCLUDE 'BLK1.COM' ! Plot arrows on control structures DO N=1,NE IF(IMAT(N) .GT. 903) THEN DIRX=CORD(NOP(N,3),1)-CORD(NOP(N,1),1) DIRY=CORD(NOP(N,3),2)-CORD(NOP(N,1),2) IF(DIRX .EQ. 0. .AND. DIRY .EQ. 0.) THEN DIR=0. ELSEIF(NCORN(N) .LT. 6) THEN DIR=ATAN2(DIRY,DIRX) D1=CORD(NOP(N,1),1) D2=CORD(NOP(N,1),2) ELSE DIR=ATAN2(DIRX,-DIRY) IF(NOP(N,2) .NE. 0) THEN D1=CORD(NOP(N,2),1) D2=CORD(NOP(N,2),2) ELSE D1=(CORD(NOP(N,1),1)+CORD(NOP(N,3),1))/2. D2=(CORD(NOP(N,1),2)+CORD(NOP(N,3),2))/2. ENDIF ENDIF DIR1=DIR+2.35619 DIR2=DIR-2.35619 IF(IESKP(N) .EQ. 0) THEN IF(NOP(N,2) .NE. 0) THEN D1=CORD(NOP(N,2),1) D2=CORD(NOP(N,2),2) ELSE D1=(CORD(NOP(N,1),1)+CORD(NOP(N,3),1))/2. D2=(CORD(NOP(N,1),2)+CORD(NOP(N,3),2))/2. ENDIF DE1=D1+0.4*COS(DIR) DE2=D2+0.4*SIN(DIR) DEA1=DE1+0.1*COS(DIR1) DEA2=DE2+0.1*SIN(DIR1) DEB1=DE1+0.1*COS(DIR2) DEB2=DE2+0.1*SIN(DIR2) CALL RRED CALL PLOTT(D1,D2,3) CALL PLOTT(DE1,DE2,2) CALL PLOTT(DEA1,DEA2,2) CALL PLOTT(DE1,DE2,3) CALL PLOTT(DEB1,DEB2,2) CALL RBLUE ENDIF ENDIF ENDDO RETURN END SUBROUTINE PLOTCRSS(isw) USE BLK1MOD ! INCLUDE 'BLK1.COM' INCLUDE 'TXFRM.COM' ! COMMON/ICN1/ ICN(MAXP) CHARACTER*11 PART1,PART2 if(isw .eq. 0) then CALL RGREEN DO NN=1,NCRSEC N=IVMIL(NN) IF(N .EQ. 0) CYCLE xpt=(xcrs(n)+xs)/txscal ypt=(ycrs(n)+ys)/txscal a=NOREACH(N)/1000. fpn=n+a IF(XPT .GT. 0. .AND. XPT .LT. HSIZE) THEN IF(YPT .GT. 0. .AND. YPT .LT. 7.5) THEN call plotcr(xpt,ypt,0.05) CALL NUMBR(xpt,ypt-0.1,0.13,FPN,0.0,3) ENDIF ENDIF ENDDO ENDIF IF(ISW .EQ. 1) THEN DO J=1,MAXP ICN(J)=0 END DO ! First sort out the potential midsides ! Note that transition elements caues a problem ! Find these first DO 200 N=1,NE if(NCORN(N) .GT. 5) GO TO 200 IF(NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN ! ! We have a transition mark node number as if it were corner ! ICN(NOP(N,3))=1 ICN(NOP(N,1))=2 ICN(NOP(N,4))=2 ICN(NOP(N,5))=2 ELSE ! ! Store ICN = 2 for corner nodes ! NCN=NCORN(N) !IPKOCT93 IF(IMAT(N) .GT. 900) THEN IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN MST=1 ELSE MST=2 ENDIF DO 180 M=1,NCN,MST ICN(NOP(N,M))=2 180 CONTINUE ENDIF 200 END DO DO J=1,NP IF(ICN(J) .EQ. 2) THEN WRITE(PART1,'(I5,F6.3)') & ,NRIVCR1(J),WTRIVCR1(J) WRITE(PART2,'(I5,F6.3)') & ,NRIVCR2(J),WTRIVCR2(J) IF (CORD(J,1) .LT. VDX) GO TO 300 X = CORD(J,1) Y = CORD(J,2) CALL RBlack IF(X .GT. 0. .AND. X .LT. HSIZE) THEN IF(Y .GT. 0. .AND. Y .LT. 7.5) THEN CALL SYMBL(X-0.25,Y+.24,0.10,PART1,0.0,11) CALL SYMBL(X-0.25,Y+.12,0.10,PART2,0.0,11) endif ENDIF 300 CONTINUE ENDIF ENDDO ENDIF CALL RBlue RETURN END