!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR CHNAGED ELEMENTS/NODES !ipk last update Jan25 2001 fix when deleting center-mid expand ipsw ! last change ipk 12 July 1999 ! Last change: IPK 13 Jan 98 10:01 am !ipk last update Nov 18 1997 !ipk last updated Oct 23 1996 !ipk last updated June 23 1996 !ipk last updated Oct 25 1995 SUBROUTINE GETELM(NEM) ! ! Routine to find first free element number ! USE BLK1MOD ! INCLUDE 'BLK1.COM' ! DO 200 J=NELAST,NE IF(IMAT(J) .EQ. 0) THEN NEM=J NELAST=J RETURN ENDIF 200 END DO NE=NE+1 NELAST=NE NEM=NE RETURN END ! SUBROUTINE GETNOD(NPT) ! ! Routine to find first free node number ! USE BLK1MOD ! INCLUDE 'BLK1.COM' ! IF(NP .GT. 0) THEN DO 200 J=NPLAST,NP IF(INEW(J) .EQ. 0) THEN NPT=J NPLAST=J RETURN ENDIF 200 END DO ELSE NP=0 ENDIF NP=NP+1 NPLAST=NP NPT=NP IF(NPT .GT. MAXP) THEN CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Execution terminated, nodal limits exceeded. Backup written','LIMITS EXCEEDED') CALL WRTOUT(0) STOP ENDIF !IPK MAY03 ICHG=0 RETURN END ! !*********************************************************************** ! SUBROUTINE DELETN(J) ! USE BLK1MOD ! INCLUDE 'BLK1.COM' ! ! Search for elements that attach to node J and remove them ! DO 200 N=1,NE IF(IMAT(N) .GT. 0) THEN NCN=NCORN(N) DO 180 K=1,NCN IF(NOP(N,K) .EQ. J) THEN !IPK APR94 IF(IMAT(N) .LT. 901 .OR. IMAT(N) .GT. 903) THEN IF(MOD(K,2) .EQ. 0) THEN IF(NCN .NE. 2) THEN IF(NCN .NE. 5 .OR. K .EQ. 2) THEN NOP(N,K)=0 GO TO 200 ENDIF !IPK APR94 END CHANGES ENDIF ENDIF ENDIF IMAT(N)=0 XC(N)=VOID YC(N)=VOID NCORN(N)=0. IF(N .LT. NELAST) NELAST=N DO 170 KK=1,8 NOP(N,KK)=0 170 CONTINUE IESKP(N)=1 GO TO 200 ENDIF 180 CONTINUE ENDIF 200 END DO !IPK FEB08 TEST FOR LOWERING NE DO N=NE,1,-1 IF(IMAT(N) .NE. 0) THEN JJ=N GO TO 225 ENDIF ENDDO 225 NE=JJ ! ! Remove node now ! CORD(J,1)=VOID CORD(J,2)=VOID XUSR(J) = VOID YUSR(J) = VOID INSKP(J)=1 INEW(J) = 0 WD(J)=-9999. WIDTH(J)=0. SS1(J)=0. SS2(J)=0. WIDS(J)=0. IF(NPLAST .GT. J) NPLAST=J !IPK FEB08 TEST FOR LOWERING NE IF(J .EQ. NP) THEN DO N=NP,1,-1 IF(INEW(N) .NE. 0) THEN JJ=N GO TO 250 ENDIF ENDDO 250 NP=JJ ENDIF RETURN END ! ! !*********************************************************************** function lenstr(str) ! ! Find length of string (position of last non-blank character) ! character*(*) str n = len(str) lenstr = n do 10 i=0,n-1 idx = n-i if (str(idx:idx) .ne. ' ') then lenstr = idx return endif 10 continue return END ! !**************************************************************** ! subroutine prox(x,y,npts,xx,yy,ipt,iflag,inskp,ibox) ! x=array of x node locations ! y=array of y node location ! npts= max number of nodes ! xx=x screen lpcation ! yy=y screen location ! iflag=character flag ! inskp=array telling nodes to skip ! ibox=any box checked save CHARACTER*80 TITLE CHARACTER*24 HLABL CHARACTER*1 ALABL(10) CHARACTER*40 MPDUM COMMON /BLKA1/ TITLE,HLABL,ALABL & & ,MPDUM !ipk oct 95 lines defining MPDUM added ! !ipk jan01 expand IPSW COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout ! integer*2 inskp(*) !IPK MAY02 REAL*8 x(*),y(*) character*1 iflag ! ! if(ibox .eq. 0) then ! nbx=2 ! call boxr(nbx) ! endif ! ! Get location of cursor ! 10 call xyloc(xscrn,yscrn,iflag,ibox) ! write(90,*) 'ibox,xscrn,yscrn',ibox,xscrn,yscrn,irmain ! write(90,7893) iflag 7893 format(' iflag',a2) ! read(*,*) junk if(irmain .eq. 1) return if(ibox .eq. 10) then iflag = 'q' return elseif(ibox .eq. 9) then iflag = 'r' ! elseif(ibox .eq. 7) then ! iflag = 'a' endif ! ! if (iflag .eq. 'q') then return elseif(iflag .eq. 'r') then return elseif(iflag .ne. 'c') then ibox=0 if(iflag .eq. 't') return if(iflag .eq. 'l') return if(iflag .eq. 'f') return if(iflag .eq. 'e') return if(iflag .eq. 'a') return if(iflag .eq. 'j') return if(iflag .eq. 'z') return if(iflag .eq. 'n') return if(iflag .eq. 'g') return if(iflag .eq. 'h') return !ipk oct96 add line below if(iflag .eq. 'b') return if(iflag .eq. 'U') return ! if(iflag .eq. 'm') go to 12 !ipk jan98 write(*,*) char(7),char(7) go to 10 endif ! ! Compare to coordinates 12 d = 1.E+20 do 20 i=1,npts !! write(*,*) 'i,npts',i,npts,inskp(i),x(i),y(i) if(inskp(i) .ne. 0) go to 20 dist = sqrt( (xscrn-x(i))**2 + (yscrn-y(i))**2) if (dist .lt. d) then d = dist ipt = i xx = x(i) yy = y(i) endif 20 continue return ! ! END !*********************************************************** subroutine zoom ! USE BLK1MOD ! INCLUDE 'BLK1.COM' ! dimension xot(5),yot(5) character*1 iflag,ans ! !ipk jun96 add zoomj character*36 zoomh,zoomj,IFLAG32 character*22 zoomi !ipk jan98 CHARACTER*80 lind data zoomh/' Zooming, click at diagonal corners'/ data zoomi/' Click left if size OK'/ !ipk jun96 add zoomj data zoomj/' Double click, click second point '/ ! ! 80 CALL CLRBOX CALL SYMBL(0.,7.70,0.20,zoomh,0.,36) !jan09 xcc = 5.00 xcc = 5.00*hsize/10. ycc = 3.5 ! 100 continue ! ! Get cursor location ! CALL XYLOC(xscrn,yscrn,iflag,ibox) IF(IRMAIN .EQ. 1) RETURN ! if (iflag .eq. 'q') return ! xp = xmin + xscrn yp = ymin + yscrn if(iflag .eq. 'c') then ! ! This option is creating an inset window ! !ipk jun96 add new path 120 continue CALL XYLOC(xscrn1,yscrn1,iflag,ibox) IF(IRMAIN .EQ. 1) RETURN if(iflag .eq. 'c') then ! ! Look for a screen size ! xsiz=abs(xscrn1-xscrn) ysiz=abs(yscrn1-yscrn) !ipk jun96 test for zero sizes if(xsiz .lt. 0.001 .or. ysiz .lt. 0.001) then CALL CLRBOX CALL SYMBL(0.,7.70,0.20,zoomj,0.,36) go to 120 endif if(xscrn1 .lt. xscrn) xscrn=xscrn1 if(yscrn1 .lt. yscrn) yscrn=yscrn1 fact=HSIZE/xsiz !jan09 if(7./ysiz .lt. fact) fact=7./ysiz if(7.5/ysiz .lt. fact) fact=7.5/ysiz xot(1)=xscrn xot(5)=xscrn yot(1)=yscrn yot(5)=yscrn yot(2)=yscrn xot(4)=xscrn !jan09 xscrn=xscrn+5./fact !jan09 yscrn=yscrn+3.5/fact xscrn=xscrn+xcc/fact yscrn=yscrn+3.75/fact !jan09 xot(2)=xscrn+5./fact xot(2)=xscrn+xcc/fact xot(3)=xot(2) !jan09 yot(3)=yscrn+3.5/fact yot(3)=yscrn+3.75/fact yot(4)=yot(3) call DASHLN(xot,yot,5,1) xp=xscrn yp=yscrn CALL CLRBOX CALL SYMBL(0.,7.70,0.20,zoomi,0.,22) CALL XYLOC(xscrn1,yscrn1,iflag,ibox) IF(IRMAIN .EQ. 1) RETURN if(iflag .ne. 'c') go to 80 go to 280 ! ! pan right ! else if(iflag .eq. 'r') then fact=1.0 !jan09 xscrn=xscrn+5.0 xscrn=xscrn+hsize/2. xp=xscrn yp=yscrn ! ! pan left ! else if(iflag .eq. 'l') then fact=1.0 !jan09 xscrn=xscrn-5.0 xscrn=xscrn-hsize/2. xp=xscrn yp=yscrn endif ! ! redraw at half size ! elseif(iflag .eq. 'r') then fact = 0.500 ! ! user controlled redraw ! else call setd(23) write (*,*) ' factor ' read(*,*) fact call setd(2) endif do 250 i=1,np if(cord(i,1) .gt. void) then inskp(i)=0 endif 250 continue do 270 i=1,ne if(imat(i) .gt. 0) then ieskp(i)=0 endif 270 continue 280 continue pscale = pscale/fact xmino=xmin ymino=ymin ! xmin = xp - (xcc*pscale) ymin = yp - (ycc*pscale) ! if(iflag .eq. 'c') then ! CALL PLOTS(0) !ipk nov97 add (0) CALL PLOTOT(0) return elseif(iflag .eq. 'r') then ! CALL PLOTS(0) !ipk nov97 add (0) CALL PLOTOT(0) return elseif(iflag .eq. 'l') then ! CALL PLOTS(0) !ipk nov97 add (0) CALL PLOTOT(0) return endif call setd(23) write(lind,*) 'Illegal zoom press return to continue' call symbl & & (1.1,7.1,0.20,LIND,0.0,80) ndig=1 CALL GTCHARX(IFLAG32,NDIG,5.0,7.6) !ipk jan98 write(*,*) 'O.K. to plot at this scale? (y)es .or. (n)o' !ipk jan98 write(*,*) 'Note n means redraw old plot' !ipk jan98 read(*,'(a)') ans !ipk jan98 call setd(2) !ipk jan98 if (ans .eq. 'y') then ! CALL PLOTS(0) !ipk nov97 add (0) CALL PLOTOT(0) return !ipk jan98 endif pscale = pscale * fact xmin=xmino ymin=ymino ! CALL PLOTS(0) !ipk nov97 add (0) CALL PLOTOT(0) return END !*********************************************************** SUBROUTINE DELETM(ISW) ! USE BLK1MOD INCLUDE 'BFILES.I90' ! INCLUDE 'BLK1.COM' ! ! COMMON /ICN1/ ICN(MAXP) DIST(N1,N2)=SQRT((CORD(N1,1)-CORD(N2,1))**2 & & +(CORD(N1,2)-CORD(N2,2))**2) DO 150 J=1,MAXP ICN(J)=0 150 END DO IF(ISW .EQ. 2) GO TO 650 ! First sort out the potential midsides ! Note that transition elements caues a problem ! Find these first IRDONE=0 DO 200 N=1,NE 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 if(imat(n) .eq. 0) then ncorn(n)=0 go to 200 endif ! ! 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 ! ! test ISW ! if isw=0 then delete all midsides except at transition ! if isw=1 then delete only midsides that are truely in the middle ! IF(ISW .EQ. 0) THEN DO 400 N=1,NE !IPKOCT93 IF(IMAT(N) .LT. 901) THEN IF(IMAT(N) .LT. 901 .OR. IMAT(N) .GT. 903) THEN IF(NCORN(N) .EQ. 5) THEN NCN=3 ELSE NCN=NCORN(N) ENDIF DO 350 M=2,NCN,2 J=NOP(N,M) !SEP93 IPK IF(J .EQ. 0) GO TO 350 !SEP93 IPK IF(ICN(J) .NE. 1) THEN NOP(N,M)=0 IF(ICN(J) .EQ. 0) THEN ! ! Remove node now ! CORD(J,1)=VOID CORD(J,2)=VOID XUSR(J) = VOID YUSR(J) = VOID INSKP(J)=1 INEW(J) = 0 WD(J)=-9999. WIDTH(J)=0. SS1(J)=0. SS2(J)=0. WIDS(J)=0. !IPK MAY03 ICHG=0 IF(NPLAST .GT. J) NPLAST=J ENDIF ENDIF 350 CONTINUE ENDIF 400 CONTINUE ELSE DO 600 N=1,NE IF(IMAT(N) .LT. 901) THEN IF(NCORN(N) .EQ. 5) THEN NCN=3 ELSE NCN=NCORN(N) ENDIF DO 550 M=2,NCN,2 J1=M-1 IF(M .EQ. NCN) THEN J2=1 ELSE J2=M+1 ENDIF J=NOP(N,M) !ipk jul99 if(j .gt. 0) then !ipk jan01 IF(INEW(J) .EQ. 0 .or. inew(j) .eq. 2) THEN inew(j)=0 NOP(N,M)=0 GO TO 550 ENDIF else go to 550 endif ! ! Test for distance separation of midside node ! XMID=(CORD(NOP(N,J1),1)+CORD(NOP(N,J2),1))/2. YMID=(CORD(NOP(N,J1),2)+CORD(NOP(N,J2),2))/2. DM=SQRT((XMID-CORD(J,1))**2+(YMID-CORD(J,2))**2) DL=DIST(J1,J2) IF(DM .LT. 0.005*DL) THEN IF(ICN(J) .NE. 1) THEN NOP(N,M)=0 IF(ICN(J) .EQ. 0) THEN ! ! Remove node now ! CORD(J,1)=VOID CORD(J,2)=VOID XUSR(J) = VOID YUSR(J) = VOID INSKP(J)=1 INEW(J) = 0 WD(J)=-9999. WIDTH(J)=0. SS1(J)=0. SS2(J)=0. WIDS(J)=0. !IPK MAY03 ICHG=0 IF(NPLAST .GT. J) NPLAST=J ENDIF ENDIF ENDIF 550 CONTINUE ENDIF 600 CONTINUE ENDIF !IPK FEB08 RESET NP DO J=NP,1,-1 IF(INEW(J) .NE. 0) THEN JJ=J GO TO 625 ENDIF ENDDO 625 CONTINUE NP=JJ RETURN !- !-.....FIND MISSING NODE NUMBERS..... !- 650 CONTINUE DO 700 I=1,MAXP 700 ICN(I) = 0 DO 725 J = 1, NE IF( IMAT(J) .EQ. 0 ) GO TO 725 DO 720 K = 1, 8 IF( NOP(J,K) .LE. 0) GOTO 720 ICN(NOP(J,K))=999 720 CONTINUE 725 END DO ! ! Remove nodes ! DO 800 J=1,NP IF(ICN(J) .EQ. 0) THEN CORD(J,1)=VOID CORD(J,2)=VOID XUSR(J) = VOID YUSR(J) = VOID INSKP(J)=1 INEW(J) = 0 WD(J)=-9999. WIDTH(J)=0. SS1(J)=0. SS2(J)=0. WIDS(J)=0. IF(NPLAST .GT. J) NPLAST=J !IPK MAY03 ICHG=0 ENDIF 800 END DO !IPK FEB08 RESET NP DO J=NP,1,-1 IF(INEW(J) .NE. 0) THEN JJ=J GO TO 900 ENDIF ENDDO 900 CONTINUE NP=JJ RETURN END !**************************************************************** ! subroutine prox2(x,y,npts,xx,yy,ipt,xx2,yy2,ipt2,iflag,inskp,ibox) save CHARACTER*80 TITLE CHARACTER*24 HLABL CHARACTER*1 ALABL(10) CHARACTER*40 MPDUM COMMON /BLKA1/ TITLE,HLABL,ALABL ,MPDUM !ipk oct 95 lines defining MPDUM added ! !ipk jan01 expand IPSW COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout ! integer*2 inskp(*) !IPK MAY02 REAL*8 x(*),y(*) character*1 iflag ! ! if(ibox .eq. 0) then ! nbx=2 ! call boxr(nbx) ! endif ! ! Get location of cursor ! 10 call xyloc(xscrn,yscrn,iflag,ibox) if(irmain .eq. 1) return if(ibox .eq. 10) then iflag = 'q' return elseif(ibox .eq. 9) then iflag = 'r' endif ! ! if (iflag .eq. 'q') then return elseif(iflag .eq. 'r') then return elseif(iflag .ne. 'c') then ibox=0 if(iflag .eq. 't') return if(iflag .eq. 'l') return if(iflag .eq. 'f') return if(iflag .eq. 'e') return if(iflag .eq. 'a') return if(iflag .eq. 'j') return if(iflag .eq. 'z') return if(iflag .eq. 'n') return if(iflag .eq. 'g') return if(iflag .eq. 'h') return ! if(iflag .eq. 'm') go to 12 !ipk jan98 write(*,*) char(7),char(7) go to 10 endif ! ! Compare to coordinates ! ipt2=0 12 d = 1.E+20 do 20 i=1,npts if(inskp(i) .ne. 0) go to 20 dist = sqrt( (xscrn-x(i))**2 + (yscrn-y(i))**2) if (dist .lt. d) then if(i .ne. ipt) then xx2=x(i) yy2=y(i) ipt2=i d = dist go to 20 endif endif 20 continue return ! END SUBROUTINE CVF(FPN,IDEC,NUMSTR,NUMC) ! ! Routine to convert number to array and prepare for plotting ! CHARACTER*36 NUMSTR CHARACTER*36 FMT,FMT1 IF(FPN .NE. 0.) THEN if(idec .eq. 1) then NDIG = ALOG10(ABS(FPN)+0.05) elseif(idec .eq. 2) then NDIG = ALOG10(ABS(FPN)+0.005) elseif(idec .eq. 3) then NDIG = ALOG10(ABS(FPN)+0.0005) else NDIG = ALOG10(ABS(FPN)+0.50005) endif ELSE NDIG = 0 ENDIF ! ! Check for Numbers than 10 ! IF(NDIG .LE. 0) THEN ! ! Check for negative numbers ! IF(FPN .LT. 0.) THEN ! ! Check for integer plot ! IF(IDEC .LT. 0) THEN NUMC = 2 IF(FPN .EQ. 0) NUMC=1 ELSE ! ! This is a negative number less than 10 ! NUMC = IDEC+3 ENDIF ! ! Check for integer plot probably a zero ! ELSEIF(IDEC .LT. 0) THEN NUMC = 1 ELSE ! ! This is a positive number less than 1 ! NUMC = IDEC+2 ENDIF ! ! Now check numbers of magnitude greater than 1 ! ELSEIF(FPN .LT. 0.) THEN ! ! Check for integer plot. A negative number ! IF(IDEC .LT. 0) THEN NUMC = NDIG+2 ELSE ! ! This is a negative number smaller than -1. ! NUMC = IDEC+NDIG+3 ENDIF ! ! Check for integer plot. A positive number ! ELSEIF(IDEC .LT. 0) THEN NUMC = NDIG+1 ELSE ! ! This is a positive number greater than 1. ! NUMC = IDEC+NDIG+2 ENDIF IF(IDEC .LT. 0) THEN IF(FPN .LT. 0.) THEN NUM = FPN-0.5 ELSE NUM = FPN+0.5 ENDIF WRITE(FMT,97) NUMC WRITE(NUMSTR,FMT) NUM 97 FORMAT('(I',i1,')') ELSE !ipk mar95 fix bug that causes error when IDEC >12 if(idec .gt. 9) then write(fmt1,99) numc,idec 99 format('(F',i2,'.',i2,')') else WRITE(FMT1,98) NUMC,IDEC 98 FORMAT('(F',i2,'.',i1,')') endif WRITE(NUMSTR,FMT1) FPN ENDIF RETURN END !ipk oct96 routines below added SUBROUTINE GTCHARX(DATA,NDIG,XLC,YLC) COMMON /RECOD/ IRECD,TSPC CHARACTER*32 DATA if(irecd .eq. 2) then read(91,'(A32)') DATA CALL INTRVL(TA,0) 70 CALL INTRVL(TA,1) IF(TA .LT. TSPC) GO TO 70 return endif 80 CONTINUE DO 90 I=1,NDIG DATA(I:I)=' ' 90 END DO ! I = 1 10 CONTINUE I = I+1 call keybrd(key) IF (KEY .EQ. 8) THEN I = I-2 xp=XLC+(i+1)*0.20 call drblk(xp,YLC+0.23,0.20,0.30,-11) GO TO 10 ENDIF IF(KEY .EQ. 13 .OR. I .EQ. ndig+2) GO TO 200 if(key .eq. 1072 .or. key .eq. 1075 .or. key .eq. 1077 .or.& & key .eq. 1080) go to 200 DATA(I-1:I-1)=CHAR(KEY) xp=XLC+i*0.20 call drblk(xp,YLC+0.23,0.20,0.30,-11) call rblue call symbl(xp,YLC,0.20,data(i-1:i-1),0.0,1) 100 CONTINUE GO TO 10 200 CONTINUE NDIG=I-2 call rblue RETURN !ipk mar94 add END SUBROUTINE DRBLK(XS,YS,XL,YL,ICOL) DIMENSION X(4),Y(4) X(1)=XS X(2)=XS X(3)=XS+XL X(4)=XS+XL Y(1)=YS Y(2)=YS-YL Y(3)=Y(2) Y(4)=YS ! WRITE(90,*) 'GOING TO POLYFL',X,Y,ICOL CALL POLYFL(X,Y,4,ICOL) call rblue RETURN END SUBROUTINE GTFPNX(FPN,NDEC,NDIG,XLC,YLC) CHARACTER*11 DATA CHARACTER*30 MES REAL HSIZE COMMON /SSIZE/ HSIZE DATA MES/'Error reading number, Reenter.'/ 80 CONTINUE DO 90 I=1,11 DATA(I:I)=' ' 90 END DO ! I = 1 NDEC=-2 10 CONTINUE I = I+1 call keybrd(key) ! WRITE(90,*) 'BACK FROMKEYBRD',KEY,I IF (KEY .EQ. 8) THEN I = I-2 xp=xlc+(i+1)*0.20 call drblk(xp,ylc+0.23,0.20,0.30,13) GO TO 10 ENDIF IF(KEY .EQ. 46) THEN NDEC=-1 ENDIF IF(KEY .EQ. 13) GO TO 200 if(key .eq. 1072 .or. key .eq. 1075 .or. key .eq. 1077 .or.& & key .eq. 1080) go to 200 IF(NDEC .GE. -1) NDEC=NDEC+1 DATA(I:I)=CHAR(KEY) ! WRITE(90,'(A)') ' GETTING CHAR',DATA(I:I) xp=xlc+i*0.20 ! WRITE(90,*) 'GOING TO DRBLK',XP,YLC call drblk(xp,ylc+0.23,0.20,0.30,-11) ! WRITE(90,*) 'BACK FROM DRBLK' call rblue call symbl(xp,ylc,0.20,data(i:i),0.0,1) 100 CONTINUE GO TO 10 200 CONTINUE NDIG=I-2 READ(DATA,5000,ERR=300) FPN 5000 FORMAT(1X,F10.0) call rblue RETURN 300 CONTINUE CALL SYMBL(3.0,1.73,0.20,MES,0.0,30) GO TO 80 END SUBROUTINE GTINTX(INUM,NDIG,XLC,YLC) CHARACTER*11 DATA CHARACTER*30 MES DATA MES/'Error reading integer, Reenter'/ 80 CONTINUE DO 90 I=1,11 DATA(I:I)=' ' 90 END DO ! I = 1 10 CONTINUE I = I+1 call keybrd(key) IF (KEY .EQ. 8) THEN I = I-2 xp=xlc+(i+1)*0.20 call drblk(xp,ylc+0.00,0.20,0.32,-11) GO TO 10 ENDIF IF(KEY .EQ. 13) GO TO 200 if(key .eq. 1072 .or. key .eq. 1075 .or. key .eq. 1077 .or.& & key .eq. 1080) go to 200 DATA(I:I)=CHAR(KEY) xp=xlc+i*0.20 call drblk(xp,ylc+0.00,0.20,0.32,-11) call rblue call symbl(xp,ylc-0.20,0.20,data(i:i),0.0,1) 100 CONTINUE GO TO 10 200 CONTINUE NDIG=I-2 READ(DATA,5000,ERR=300) INUM 5000 FORMAT(1X,I10) call rblue RETURN 300 CONTINUE CALL SYMBL(3.0,1.73,0.20,MES,0.0,30) GO TO 80 END SUBROUTINE WRTBOX(IDELV) dimension x(5),y(5) CHARACTER*6 label COMMON /SSIZE/ HSIZE DATA label/'(e)lsw'/ ! ! Draw box around selections with colour ! Y(1)=7.5 Y(2)=7.5 Y(3)=7.995 Y(4)=7.995 Y(5)=7.5 X(1)=6.0*HSIZE/10. X(2)=7.0*HSIZE/10. X(3)=7.0*HSIZE/10. X(4)=6.0*HSIZE/10. X(5)=6.0*HSIZE/10. IF(IDELV .EQ. 1) THEN IBLK=12 ELSE IBLK= 8 ENDIF 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) call symbl(6.02*hsize/10.,7.6,0.20,label,0.0,6) RETURN END SUBROUTINE UNDOACT USE BLK1MOD ! INCLUDE '!BLK1.COM' ! IF(NEUNDO .GT. 0) THEN ! DO N=1,NEUNDO ! J=IELDEL(N) ! CALL DELTEL(J) ! ENDDO ! ELSE ! RETURN ! ENDIF IF(NPUNDO .GT. 0) THEN DO N=1,NPUNDO J=NODDEL(N) if(j .gt. 0) CALL DELETN(J) ENDDO ENDIF NPUNDO=0 NEUNDO=0 WRITE(90,*) 'NESAV,NEFSAV',NESAV,NEFSAV,NE,NENTRY IF(NESAV .GT. 0) THEN DO J=1,NESAV DO K=1,8 NOP(J,K)=NOPSV(J,K) ENDDO NCN = 2 IF (NOP(J,3) .NE. 0) NCN = 3 IF (NOP(J,4) .NE. 0) NCN = 4 IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5 IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6 IF (NOP(J,6) .NE. 0) NCN = 6 IF (NOP(J,7) .NE. 0) NCN = 8 NCORN(J) = NCN IESKP(J) = 0 IMAT(J)=IMATSV(J) ENDDO NE=NESAV ENDIF NESAV=0 IF(NENTRY .GT. NEFSAV) THEN IF(NEFSAV .GT. 0) THEN DO N=1,NEFSAV DO M=1,3 NEF(N,M)=NEFSV(N,M) ENDDO ENDDO ENDIF NENTRY=NEFSAV ENDIF NEFSAV=NENTRY CALL PLOTOT(-1) CALL HEDR RETURN END SUBROUTINE GETXC USE BLK1MOD DO J=1,NE XXC=0. YYC=0. IF(IMAT(J) .EQ. 0) GO TO 50 NCN = NCORN(J) IF(NCN .EQ. 9) THEN NCNR=8 ELSE NCNR=NCN ENDIF DO 25 K=1,NCNR N = NOP(J,K) ! IF (N .EQ. 0) GO TO 25 IF (CORD(N,1) .LT. VDX) GOTO 25 ! ! IF (NCN .NE. 5 .OR. K .LT. 5) THEN IF (MOD(K,2) .EQ. 1) THEN XXC = XXC + CORD(N,1) YYC = YYC + CORD(N,2) ENDIF ENDIF 25 END DO IF (NCN .EQ. 3 .OR. NCN .EQ. 5) NCN = 4 IF(NCN .LT. 9) THEN XC(J) = 2.*XXC/NCN YC(J) = 2.*YYC/NCN ELSE XC(J)= CORD(NOP(J,9),1) YC(J)= CORD(NOP(J,9),2) ENDIF 50 CONTINUE ENDDO RETURN END SUBROUTINE DELETEM USE WINTERACTER USE BLK1MOD SAVE ! implicit none include 'd.inc' INCLUDE 'TXFRM.COM' INCLUDE 'BFILES.I90' CHARACTER*1 IFLAG CHARACTER*24 MESSAG INTEGER NTYPR,ITIMETHRU DATA MESSAG/'GET ELEMENT TYPE NUMBER '/ ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE call wdialogload(IDD_GETINT) ierr=infoerror(1) CALL WDialogSelect(IDD_GETINT) ierr=infoerror(1) NFD=0 CALL WDialogPutString(IDF_STRING1,MESSAG) CALL WDialogPutInteger(IDF_INTEGER1,NFD) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) ! Branch depending on type of message. ! DO IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN CALL WDialogGetInteger(IDF_INTEGER1,NFD) GO TO 200 ENDIF ENDDO 200 CONTINUE IF(NFD .EQ. 0) RETURN ! ASK FOR ELEMENT NUMBER ! LOOP ON ELEMENTS DROPPING ELEMENTS OF GIVEN TYPE DO N=1,NE IF(IMAT(N) .EQ. NFD) THEN DO K=1,8 NOP(N,K)=0 ENDDO IMAT(N)=0 NCORN(N)=0 ENDIF ENDDO RETURN END ! !**************************************************************** ! subroutine proxel(x,y,npts,xx,yy,ipt,iflag,inskp,ibox,neac) ! x=array of x node locations ! y=array of y node location ! npts= max number of nodes ! xx=x screen lpcation ! yy=y screen location ! iflag=character flag ! inskp=array telling nodes to skip ! ibox=any box checked save CHARACTER*80 TITLE CHARACTER*24 HLABL CHARACTER*1 ALABL(10) CHARACTER*40 MPDUM COMMON /BLKA1/ TITLE,HLABL,ALABL & & ,MPDUM !ipk oct 95 lines defining MPDUM added ! !ipk jan01 expand IPSW COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout ! integer*2 inskp(*) INTEGER neac(*) !IPK MAY02 REAL*8 x(*),y(*) character*1 iflag ! ! if(ibox .eq. 0) then ! nbx=2 ! call boxr(nbx) ! endif ! ! Get location of cursor ! 10 call xyloc(xscrn,yscrn,iflag,ibox) ! write(90,*) 'ibox,xscrn,yscrn',ibox,xscrn,yscrn,irmain ! write(90,7893) iflag 7893 format(' iflag',a2) ! read(*,*) junk if(irmain .eq. 1) return if(ibox .eq. 10) then iflag = 'q' return elseif(ibox .eq. 9) then iflag = 'r' ! elseif(ibox .eq. 7) then ! iflag = 'a' endif ! ! if (iflag .eq. 'q') then return elseif(iflag .eq. 'r') then return elseif(iflag .ne. 'c') then ibox=0 if(iflag .eq. 't') return if(iflag .eq. 'l') return if(iflag .eq. 'f') return if(iflag .eq. 'e') return if(iflag .eq. 'a') return if(iflag .eq. 'j') return if(iflag .eq. 'z') return if(iflag .eq. 'n') return if(iflag .eq. 'g') return if(iflag .eq. 'h') return !ipk oct96 add line below if(iflag .eq. 'b') return if(iflag .eq. 'U') return ! if(iflag .eq. 'm') go to 12 !ipk jan98 write(*,*) char(7),char(7) go to 10 endif ! ! Compare to coordinates 12 d = 1.E+20 do ii=1,8 i=neac(ii) if(neac(ii) .eq. 0) cycle !! write(*,*) 'i,npts',i,npts,inskp(i),x(i),y(i) if(inskp(i) .ne. 0) cycle dist = sqrt( (xscrn-x(i))**2 + (yscrn-y(i))**2) if (dist .lt. d) then d = dist ipt = i xx = x(i) yy = y(i) endif enddo return ! ! END