!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 .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                                           
    