!IPK  LAST UPDATE SEP 23 2015  ADD OPTION FOR JOINING ELEMENTS
    subroutine joinel

      USE BLK1MOD
      USE BLK2MOD 
      use blkmap
      INTEGER LIST1(1000),LIST2(1000),idel(1000)
      real xmapt(1000),ymapt(1000)

      
      CHARACTER*1  IFLAG,ANSW(10) 
      CHARACTER*60  STRELS 
      DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/ 


      DATA STRELS/' You have tried to join before executing "FILL"'/ 
!                                                                       
!
!  Test to make sure fill has been executed.                            
!                                                                       
      DO N=1,NE 
        IF(IMAT(N) .GT. 0) THEN 
          DO M=2,NCORN(N),2 
!ipkoct93                                                               
            if(imat(n) .LT. 900) THEN
              IF(NOP(N,M) .EQ. 0) THEN 
                CALL SYMBL(0.,7.30,0.20,STRELS,0.,60) 
                RETURN 
              ENDIF 
            ENDIF
          ENDDO
        ENDIF 
      ENDDO
!     Initiliaze list etc

      NHTPSV=NHTP 
      NMESSSV=NMESS 
      NBRRSV=NBRR 
      
!    get starting elements
      ISWW=0
      CALL KCON(ISWW)
      DO N=1,NE
        DO M=1,8
          NOPSV(N,M)=NOP(N,M)
        ENDDO
          IMATSV(N)=IMAT(N)
      ENDDO
      NESAV=NE
      NEFSAV=NENTRY
      NPUNDO=0
      list1=0
      list2=0
!   SELECT FIRST ELEMENT
10    CONTINUE   
      CALL PANELTYP(NMTYP)
      NHTP=0 
      NMESS=20 
      NBRR=8 
      CALL HEDR
    
      CALL PROX(XC,YC,NE,XX,YY,NEL1,IFLAG,IESKP,IBOX)
      IF(IRMAIN .EQ. 1) THEN
        NHTP=NHTPSV 
        NMESS=NMESSSV 
        NBRR=NBRRSV 

        CALL HEDR
        RETURN 
      ENDIF        
     IF(IFLAG .EQ. 'c'  .AND. IBOX .GT. 0) THEN 
        IFLAG=ANSW(IBOX) 
      ENDIF 
      CALL fillem(NEL1)
!                                                                       
      IF(IFLAG .EQ. 'q') THEN 
        NHTP=NHTPSV 
        NMESS=NMESSSV 
        NBRR=NBRRSV 

        CALL HEDR
        RETURN 
      ENDIF
      
      CALL PROX(XC,YC,NE,XX,YY,NEL2,IFLAG,IESKP,IBOX)
      IF(IRMAIN .EQ. 1) THEN
        NHTP=NHTPSV 
        NMESS=NMESSSV 
        NBRR=NBRRSV 

        CALL HEDR
        RETURN 
      ENDIF        
      IF(IFLAG .EQ. 'c'  .AND. IBOX .GT. 0) THEN 
        IFLAG=ANSW(IBOX) 
      ENDIF 
!                                                                       
      IF(IFLAG .EQ. 'q') THEN 
        NHTP=NHTPSV 
        NMESS=NMESSSV 
        NBRR=NBRRSV 

        CALL HEDR
        RETURN 
      ENDIF
      CALL fillem(NEL1)
      CALL fillem(NEL2)

      CALL PROX(XC,YC,NE,XX,YY,NEL3,IFLAG,IESKP,IBOX)
      IF(IRMAIN .EQ. 1) THEN
        NHTP=NHTPSV 
        NMESS=NMESSSV 
        NBRR=NBRRSV 

        CALL HEDR
        RETURN 
      ENDIF        
      IF(IFLAG .EQ. 'c'  .AND. IBOX .GT. 0) THEN 
        IFLAG=ANSW(IBOX) 
      ENDIF 
!                                                                       
      IF(IFLAG .EQ. 'q') THEN 
        NHTP=NHTPSV 
        NMESS=NMESSSV 
        NBRR=NBRRSV 

        CALL HEDR
        RETURN 
      ENDIF
      
      CALL fillem(NEL1)
      CALL fillem(NEL2)
      CALL fillem(NEL3)
      CALL PROX(XC,YC,NE,XX,YY,NEL4,IFLAG,IESKP,IBOX)
      IF(IRMAIN .EQ. 1) THEN
        NHTP=NHTPSV 
        NMESS=NMESSSV 
        NBRR=NBRRSV 

        CALL HEDR
        RETURN 
      ENDIF        
      IF(IFLAG .EQ. 'c'  .AND. IBOX .GT. 0) THEN 
        IFLAG=ANSW(IBOX) 
      ENDIF 
!                                                                       
      IF(IFLAG .EQ. 'q') THEN 
        NHTP=NHTPSV 
        NMESS=NMESSSV 
        NBRR=NBRRSV 

        CALL HEDR
        RETURN 
      ENDIF
      CALL fillem(NEL1)
      CALL fillem(NEL2)
      CALL fillem(NEL3)
      CALL fillem(NEL4)

!    work on first pair
!    get starting mid-side
      ilc=0
      call findbcel(nel1,nd1,nd2,nd3,ierr,ilc)
!    save back node
      list1(1)=nd1
      write(90,*) '1',nd1
      
!    get adjacent corner save corner
      m=2
      list1(m)=nd3
      write(90,*) m,nd3
      nelc=nel1
      nelcsv=nel1
!    start looop
      do nss=1,1000
!    find next element and   get mid side 
        nadj=ndelm(nd3)
        do kkk=1,nadj
          nd3=list1(m)
          nelc=nelcsv
          if(necon(nd3,kkk) .ne. nelc) then
            nelc=necon(nd3,kkk)
            ilc=2
            call findbcel(nelc,nd1,nd2,nd3,ierr,ilc)
            if(ierr .eq. 0) go to 200
          endif
        enddo
200     continue   
        nelcsv=nelc
!    get and save next corner
        m=m+1
        if(m .gt. 1000) THEN
          NHTP=NHTPSV 
          NMESS=NMESSSV 
          NBRR=NBRRSV 

          CALL HEDR
          RETURN 
        ENDIF        
        list1(m)=nd3
        write(90,*) m,nd3
!    test for last element
        if(nelc .eq. nel2) go to 250
      enddo
250   continue 
      m1=m
      
!    repeat for second pair
!    get starting mid-side
      ilc=1
      call findbcel(nel3,nd1,nd2,nd3,ierr,ilc)
!    save back node
      list2(1)=nd1
      write(90,*) m,nd1
      
!    get adjacent corner save corner
      m=2
      list2(m)=nd3
      write(90,*) m,nd3
      nelc=nel3
      nelcsv=nel3
!    start looop
      do nss=1,1000
!    find next element and   get mid side 
        nadj=ndelm(nd3)
        do kkk=1,nadj
          nd3=list2(m)
          nelc=nelcsv
          if(necon(nd3,kkk) .ne. nelc) then
            nelc=necon(nd3,kkk)
            ilc=2
            if(nelc .eq. nel4) ilc=4
            call findbcel(nelc,nd1,nd2,nd3,ierr,ilc)
            if(ierr .eq. 0) go to 300
            
          endif
        enddo
300     continue   
        nelcsv=nelc
!    get and save next corner
        m=m+1
        if(m .gt. 1000) THEN
          NHTP=NHTPSV 
          NMESS=NMESSSV 
          NBRR=NBRRSV 

          CALL HEDR
        ENDIF
        list2(m)=nd3
      write(90,*) m,nd3
!    test for last element
        if(nelc .eq. nel4) go to 350
      enddo
350   continue
      m2=m
      !   add points in triangle list
      do j=1,m2
        list1(m1+j)=list2(j)
      enddo
      nvert=m1+m2
      do n=1,nvert
        write(90,*) n,list1(n)
      enddo
      do j=1,nvert
        xmap(j)=xusr(list1(j))
        ymap(j)=yusr(list1(j))
        xmapt(j)=xusr(list1(j))
        ymapt(j)=yusr(list1(j))
        imap(j)=1
        val(j)=1.
      enddo
!    call for triangulation    

      CALL DELAUNAY(NVERT) 

      do n=1,nelts
        if(nopel(n,1) .le. m1) then
          if(nopel(n,2) .le. m1  .and.  nopel(n,3) .le. m1) then
            cycle
          endif
        else
          if(nopel(n,2) .gt. m1  .and.  nopel(n,3) .gt. m1) then
            cycle
          endif
500       continue
        endif
!   FORM A NEW ELEMENT ASSIGN TYPE AS INDICATED
        CALL GETELM(J)
        NOP(J,1)=list1(nopel(n,1))
        NOP(J,3)=list1(nopel(n,2))
        NOP(J,5)=list1(nopel(n,3))
        NOP(J,2)=0
        NOP(J,4)=0
        NOP(J,6)=0
        NOP(J,7)=0
        NOP(J,8)=0
        IMAT(J)=NMTYP
        IESKP(J) = 0 
        NCORN(J)=6
      enddo
      CALL PLOTOT(1)
      NHTP=NHTPSV 
      NMESS=NMESSSV 
      NBRR=NBRRSV 

      CALL HEDR
      return
      end
      
      subroutine findbcel(nel,nd1,nd2,nd3,ierr,ilc)
      use blk1mod
      USE BLK2MOD 
      integer nel,nd1,nd2,nd3,mlc(5),ndkp
      ndkp=nd3
      ierr=0
      kk=0
      do k=2,ncorn(nel),2
        nd2=nop(nel,k)
        if(ndelm(nd2) .eq. 1) then
          nd1=nop(nel,k-1)
          if(nd1 .ne. ndkp .and. ilc .gt. 1) cycle
          jj=mod(k,ncorn(nel))+1
          nd3=nop(nel,jj)
          if(ilc .eq. 4) return
          if(ilc .gt. 0) then
            kk=kk+1
            mlc(kk)=k
            cycle
          else
!   check for more than 1 
            kj=k+2
            if(kj .gt. ncorn(nel)) kj=2
            nd2a=nop(nel,kj)
            if(ndelm(nd2a) .eq. 1) then
              nd1=nop(nel,kj-1)
              jj=mod(kj,ncorn(nel))+1
              nd3=nop(nel,jj)
              nd2=nd2a
            endif
            return
          endif
          
        endif
      enddo
      if(ilc .gt. 0) then
        if(kk .eq. 1) then
          if(nd1 .eq. ndkp) then
            return
          else
            ierr=1
            return
          endif
        elseif(kk .eq. 2) then
          if(abs(mlc(2)-mlc(1)) .eq. 4) then
            do kk=1,2
              nd1=nop(nel,mlc(kk)-1)
              if(nd1 .eq. ndkp) then
                nd2=nop(nel,mlc(kk))
                nd3=mod(mlc(kk),ncorn(nel))+1
                nd3=nop(nel,nd3)
                return
              endif
            enddo
          endif
          if(ilc .eq. 1) then
            if(mlc(kk) .eq. ncorn(nel)  .and. mlc(kk-1) .eq. 2) then
              nd1=nop(nel,1)
              nd2=nop(nel,2)
              nd3=nop(nel,3)
            else
              return
            endif
          else
            if(mlc(kk) .eq. ncorn(nel)  .and. mlc(kk-1) .eq. 2) then
              return
            else
              nd1=nop(nel,mlc(1)-1)
              nd2=nop(nel,mlc(1))
              nd3=nop(nel,mlc(1)+1)
            endif
          endif              
        elseif(kk .eq. 3) then
          if(mlc(kk) .eq. ncorn(nel)) then
            if(mlc(kk-1) .eq. ncorn(nel)-2) then
              nd1=nop(nel,1)
              nd2=nop(nel,2)
              nd3=nop(nel,3)
            elseif(mlc(kk-1) .eq. ncorn(nel)-4) then
              nd1=nop(nel,3)
              nd2=nop(nel,4)
              nd3=nop(nel,5)
            else
              return
            endif
          else
            return
          endif
        endif
!      else
!        return
      endif
      ierr=1
      return
    end
    
     SUBROUTINE PANELTYP(N1)

!    Choose options and intervals 

      use winteracter

      implicit none

      include 'D.inc'
      INCLUDE 'BFILES.I90'

!
! Declare window-type and message variables
!
      TYPE(WIN_STYLE)    :: WINDOW

      TYPE(WIN_MESSAGE) :: MESSAGE

      integer  :: N1,itime,IERR
      data itime/0/

      if(itime .eq. 0) then
        n1=1
        itime=1
      endif

      call wdialogload(IDD_MATTYP)
      ierr=infoerror(1)

      CALL WDialogPutInteger(idf_integer1,N1)

      CALL WDialogSelect(IDD_MATTYP)
      ierr=infoerror(1)

      CALL WDialogShow(-1,-1,0,Modal)
      ierr=infoerror(1)
      
      IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
          CALL WDialogGetInteger(idf_integer1,N1)
      ELSE
        N1=1 
        RETURN
  
      ENDIF
      
      RETURN
      END