You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
278 lines
7.1 KiB
Fortran
278 lines
7.1 KiB
Fortran
5 years ago
|
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
|