SUBROUTINE CREATM


      USE BLKMAP
      USE BLK1MOD
      USE BLK2MOD 
!    Routine to create mesh from map contour lines

      COMMON /CRMAP/ NCONT,CVALUE(1000),MSTART(1000),MFIN(1000),CINTDIS(1000),IACTCV(1000)

!      INCLUDE 'BLK1.COM'
!      INCLUDE 'BLK2.COM'

!    Search map data for contoour lines and setup values

      JS=1 
      NCONT=0
!                                                                       
      K=0 
      DO 20 J=1,MAXPTS
          MLEN=J-JS 
          IF(XMAP(J) .LE. VDX  .or. j .eq. maxpts) THEN 
!                                                                       
!    We have found a line end, is itmore than 1 point long?                                                         
!                                                                       
            K=K+1 
            IF(MLEN .GT. 1) THEN 
              LTP=LINTYP(K) 
                                                                        
              IF(LTP .NE. 2) THEN 
                  IF(LTP .GT. 0) THEN
                    NCONT=NCONT+1
                    CVALUE(NCONT)=VAL(JS)
                    MSTART(NCONT)=JS
                    IF(XMAP(J) .LE. VDX) THEN
                      MFIN(NCONT)=J-1
                    ELSE
                      MFIN(NCONT)=J
                    ENDIF
                  ENDIF
              ENDIF 
            ENDIF 
            IF(MLEN .EQ. 0  .AND.  LINTYP(K) .EQ. -999) GO TO 30 
            JS=J+1 
          ENDIF 
   20 CONTINUE                                                        
   30 CONTINUE


!    Choose options and intervals 

      CALL PANELCRT(NCONT,CVALUE,IACTCV,CINTDIS,ICAN)
      IF(ICAN .EQ. 1) RETURN

!    First form list of nodes working along contour lines 

      CALL CFORM

!    Now generate elements

      do n=1,np
        list(n)=1
      enddo

      call deln2(np,0)

      call checkpoly

      RETURN
      END

      SUBROUTINE PANELCRT(N1,R2,N3,R4,N5)

!    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,N2,N3(1000),IERR,ITIME,K,N5,NA,NB
      real     :: R2(1000),R4(1000)
      data itime/0/

      if(itime .eq. 0) then
        n2=0
        na=1
        nb=1
        itime=1
        do k=1,1000
          r4(k)=500.
          n3(k)=1
        enddo
      endif

      call wdialogload(IDD_CREATM1)
      ierr=infoerror(1)

      CALL WDialogPutCheckBox(idf_check1,na)
      CALL WDialogPutCheckBox(idf_check2,nb)
      CALL WDialogPutReal(idf_real1,r4(1))

      CALL WDialogSelect(IDD_CREATM1)
      ierr=infoerror(1)

      CALL WDialogShow(-1,-1,0,Modal)
      ierr=infoerror(1)
      
      IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
        CALL WDialogGetCheckBox(idf_check1,na)
        CALL WDialogGetCheckBox(idf_check2,nb)
        if(nb .eq. 1) then
          CALL WDialogGetReal(idf_real1,r4(1))
          do k=1,1000
            r4(k)=r4(1)
          enddo
        endif
        N5=0
      ELSE
        N5=1 
        RETURN
  
      ENDIF
      
      if(na .eq. 1  .and.  nb .eq. 1) return

      call wdialogload(IDD_CREATM)
      ierr=infoerror(1)

      CALL WGridPutCheckBox(idf_grid1,1,n3,n1)
      CALL WGridPutReal(idf_grid1,2,r2,n1)
      CALL WGridPutReal(idf_grid1,3,r4,n1)

      CALL WDialogSelect(IDD_CREATM)
      ierr=infoerror(1)

      CALL WDialogShow(-1,-1,0,Modal)
      ierr=infoerror(1)
      
      IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
        CALL WGridGetCheckBox(idf_grid1,1,n3,n1)
        CALL WGridGetReal(idf_grid1,2,r2,n1)
        CALL WGridGetReal(idf_grid1,3,r4,n1)
        N5=0
      ELSE
        N5=1
        RETURN
      
      ENDIF
      RETURN
      END

      SUBROUTINE CFORM

!    Form list of nodes working along contour lines 

      USE BLKMAP
      USE BLK1MOD

      COMMON /CRMAP/ NCONT,CVALUE(1000),MSTART(1000),MFIN(1000),CINTDIS(1000),IACTCV(1000)

!      INCLUDE 'BLK1.COM'
      INCLUDE 'TXFRM.COM'

      DISTC(N1,N2)=SQRT((XMAP(N1)-XMAP(N2))**2                       &
     &                +(YMAP(N1)-YMAP(N2))**2)                      

!    Loop through each active contour

      DO N=1,NCONT
        IF(IACTCV(N) .EQ. 1) THEN
           JS=MSTART(N)
           JF=MFIN(N)
           IF(XMAP(JS) .EQ. XMAP(JF)  .AND.  YMAP(JS) .EQ. YMAP(JF)) THEN
             IF(JF .GT. JS) JF=JF-1
           ENDIF
           IEND=0
           DO J=JS,JF
             IF(J .EQ. JS) THEN
               CDONE=0.
               CNODE=0
               CALL GETNOD(JJ)
               INSKP(JJ)=0 
               INEW(JJ) = 1 
!                                                                       
               XUSR(JJ) = XMAP(J)
               YUSR(JJ) = YMAP(J) 
               CORD(JJ,1)=(XUSR(JJ)+XS)/TXSCAL
               CORD(JJ,2)=(YUSR(JJ)+YS)/TXSCAL
               WD(JJ)=CVALUE(N) 
               WIDTH(JJ)=0. 
               SS1(JJ)=0. 
               SS2(JJ)=0. 
               WIDS(JJ)=0. 
               WIDBS(JJ)=0.
               SSO(JJ)=0.
               IF (JJ .GT. NP)  NP = JJ 
               CALL PLTNOD(JJ,0)
               ICHG=0 
             ELSE
               CNODEO=CNODE
               CNODE=CNODE+DISTC(J,J-1)
  200          CONTINUE
               CDIS=CDONE+CINTDIS(N)
               IF(CDIS .LE. CNODE  .OR.  J .EQ. JF) THEN
                 IF(CDIS .LE. CNODE) THEN
                   FACT=(CDIS-CNODEO)/(DISTC(J,J-1))
                   IF(J .EQ. JF  .AND.  FACT .GT. 0.999) IEND=1
                 ELSE
                   FACT=1.0
                   IEND=1
                 ENDIF
                 CALL GETNOD(JJ)
                 INSKP(JJ)=0 
                 INEW(JJ) = 1 
!                                                                         
                 XUSR(JJ) = (1.-FACT)*XMAP(J-1)+FACT*XMAP(J) 
                 YUSR(JJ) = (1.-FACT)*YMAP(J-1)+FACT*YMAP(J) 
                 CORD(JJ,1)=(XUSR(JJ)+XS)/TXSCAL
                 CORD(JJ,2)=(YUSR(JJ)+YS)/TXSCAL
                 WD(JJ)=CVALUE(N)
                 WIDTH(JJ)=0. 
                 SS1(JJ)=0. 
                 SS2(JJ)=0. 
                 WIDS(JJ)=0. 
                 WIDBS(JJ)=0.
                 SSO(JJ)=0.
                 IF (JJ .GT. NP)  NP = JJ 
                 CALL PLTNOD(JJ,0)
                 ICHG=0 
                 CDONE=CDIS
                 IF(IEND .NE. 1) GO TO 200
               ENDIF
             ENDIF
           ENDDO
        ENDIF
      ENDDO
      RETURN
    END

    SUBROUTINE CHECKPOLY
    
!  CHECK IF ELEMENTS ARE OUTSIDE POLYGON BY LOOKING AT CENTROID    
    USE BLKOUT
    USE BLK1MOD
    
    IF(NOUTLIN .EQ. 0) RETURN
    
    call FILM(1)
    NETEMP=NE
    DO N=1,NETEMP
      IF(IMAT(N) .EQ. 0) CYCLE
      XM=(XUSR(NOP(N,1))+XUSR(NOP(N,3))+XUSR(NOP(N,5)))/3.  
      YM=(YUSR(NOP(N,1))+YUSR(NOP(N,3))+YUSR(NOP(N,5)))/3.  
!      do k=2,6,2
!        xm=xusr(nop(n,k))
!        ym=yusr(nop(n,k))
        if( IGRInsidePolygon(xoutl,youtl,noutlin,xm,ym)) then
          
        else
          CALL DELTEL(n) 
          go to 200
        endif
!      enddo

200   continue        
    ENDDO
    RETURN
    END