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.
961 lines
25 KiB
Fortran
961 lines
25 KiB
Fortran
5 years ago
|
! last update feb 10 2002 add lock/unlock
|
||
|
|
! Last change: IPK 2 Mar 1999 12:05 pm
|
||
|
|
SUBROUTINE SELNODE(ISW)
|
||
|
|
|
||
|
|
USE WINTERACTER
|
||
|
|
USE BLKMAP
|
||
|
|
USE BLK1MOD
|
||
|
|
USE BLK2MOD
|
||
|
|
|
||
|
|
include 'd.inc'
|
||
|
|
|
||
|
|
dimension xot(100),yot(100)
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
! INCLUDE 'BLK2.COM'
|
||
|
|
!
|
||
|
|
dimension nodlist(maxp),RLAY(9)
|
||
|
|
! DIMENSION ICN(MAXP)
|
||
|
|
character*1 iflag
|
||
|
|
CHARACTER*1 ANS,ANSW(10)
|
||
|
|
CHARACTER*63 STRELS
|
||
|
|
DATA ANSW/'m','a','f','s','k','u','t','w','h','q'/
|
||
|
|
DATA STRELS/' You have tried set to set elevation with no mapfile"'/
|
||
|
|
|
||
|
|
|
||
|
|
!
|
||
|
|
! save nhtp etc
|
||
|
|
|
||
|
|
nhtps=nhtp
|
||
|
|
nbrs=nbrr
|
||
|
|
nmessv=nmess
|
||
|
|
if(isw .eq. 0 .or. isw .eq. 4) then
|
||
|
|
|
||
|
|
CALL GETPOLY(XOT,YOT,NPTS)
|
||
|
|
|
||
|
|
! look for points inside polygon
|
||
|
|
|
||
|
|
ndlist=0
|
||
|
|
do j=1,np
|
||
|
|
if(inskp(j) .eq. 0) then
|
||
|
|
inswt=0
|
||
|
|
call cpoly(xot,yot,npts,cord(j,1),cord(j,2),inswt)
|
||
|
|
if(inswt .eq. 1) then
|
||
|
|
call rred
|
||
|
|
fpn=j
|
||
|
|
x = cord(j,1)
|
||
|
|
y = cord(j,2) - .11
|
||
|
|
call numbr(x,y,ht,fpn,0.0,-1)
|
||
|
|
ndlist=ndlist+1
|
||
|
|
nodlist(ndlist)=j
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
call rblue
|
||
|
|
elseif(isw .eq. 1) then
|
||
|
|
!
|
||
|
|
! Add all nodes to list
|
||
|
|
!
|
||
|
|
NDLIST=0
|
||
|
|
DO J=1,NP
|
||
|
|
IF(INEW(J) .EQ. 1) THEN
|
||
|
|
NDLIST=NDLIST+1
|
||
|
|
NODLIST(NDLIST)=J
|
||
|
|
ENDIF
|
||
|
|
END DO
|
||
|
|
|
||
|
|
elseif(isw .eq. 2) then
|
||
|
|
|
||
|
|
! Get inactive nodes
|
||
|
|
|
||
|
|
DO I=1,NP
|
||
|
|
ICN(I) = 0
|
||
|
|
ENDDO
|
||
|
|
DO J = 1, NE
|
||
|
|
IF( IMAT(J) .NE. 0 ) THEN
|
||
|
|
DO K = 1, 8
|
||
|
|
IF( NOP(J,K) .GT. 0) THEN
|
||
|
|
ICN(NOP(J,K))=999
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
END DO
|
||
|
|
!
|
||
|
|
! Add nodes to list
|
||
|
|
!
|
||
|
|
NDLIST=0
|
||
|
|
DO J=1,NP
|
||
|
|
IF(ICN(J) .EQ. 0 .AND. INEW(J) .EQ. 1) THEN
|
||
|
|
NDLIST=NDLIST+1
|
||
|
|
NODLIST(NDLIST)=J
|
||
|
|
ENDIF
|
||
|
|
END DO
|
||
|
|
|
||
|
|
elseif(isw .eq. 3) then
|
||
|
|
NS=1
|
||
|
|
call wdialogload(IDD_SELELTYP)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogPutInteger(IDF_INTEGER1,NS)
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_SELELTYP)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,ModaL)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
do
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
CALL WDialogGetInteger(IDF_INTEGER1,NS)
|
||
|
|
go to 80
|
||
|
|
ENDIF
|
||
|
|
enddo
|
||
|
|
80 CONTINUE
|
||
|
|
DO I=1,NP
|
||
|
|
ICN(I) = 0
|
||
|
|
ENDDO
|
||
|
|
NDLIST=0
|
||
|
|
DO K=1,NE
|
||
|
|
IF(IMAT(K) .EQ. NS) THEN
|
||
|
|
DO L=1,8
|
||
|
|
NST=NOP(K,L)
|
||
|
|
IF(NST .GT. 0) THEN
|
||
|
|
IF(ICN(NST) .EQ. 0) THEN
|
||
|
|
NDLIST=NDLIST+1
|
||
|
|
NODLIST(NDLIST)=NST
|
||
|
|
ICN(NST)=1
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
|
||
|
|
endif
|
||
|
|
! NEW MOVE OPERATION
|
||
|
|
|
||
|
|
IF(ISW .EQ. 4) THEN
|
||
|
|
CALL MVGRP(NDLIST,NODLIST)
|
||
|
|
nhtp=nhtps
|
||
|
|
nbrr=nbrs
|
||
|
|
nmess=nmessv
|
||
|
|
call hedr
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
nbrr=0
|
||
|
|
nhtp=14
|
||
|
|
call hedr
|
||
|
|
CALL XYLOC(xscrn1,yscrn1,iflag,ibox)
|
||
|
|
if(ibox .eq. 1 .or. iflag .eq. 'd') then
|
||
|
|
do n=1,ndlist
|
||
|
|
j=nodlist(n)
|
||
|
|
call deletn(j)
|
||
|
|
enddo
|
||
|
|
elseif(ibox .eq. 2 .or. iflag .eq. 'e') then
|
||
|
|
do n=1,ndlist
|
||
|
|
j=nodlist(n)
|
||
|
|
wd(j)=-9999.
|
||
|
|
enddo
|
||
|
|
elseif(ibox .eq. 3 .or. iflag .eq. 't') then
|
||
|
|
!
|
||
|
|
! Establish size for range
|
||
|
|
!
|
||
|
|
! IF(IMP .EQ. 0) THEN
|
||
|
|
! CALL SYMBL(0.,7.25,0.20,STRELS,0.,63)
|
||
|
|
! nhtp=nhtps
|
||
|
|
! nbrr=nbrs
|
||
|
|
! nmess=nmessv
|
||
|
|
! call hedr
|
||
|
|
! RETURN
|
||
|
|
! endif
|
||
|
|
|
||
|
|
100 CONTINUE
|
||
|
|
NHTP = 16
|
||
|
|
NMESS = 0
|
||
|
|
NBRR = 0
|
||
|
|
CALL HEDR
|
||
|
|
!
|
||
|
|
! Get answer
|
||
|
|
!
|
||
|
|
110 call xyloc(XPT,YPT,ANS,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
IF(ANS .EQ. 'c') THEN
|
||
|
|
if(ibox .eq. 0) go to 110
|
||
|
|
ANS=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
IF(ANS .EQ. 'm') THEN
|
||
|
|
!
|
||
|
|
! This option allows changes to bottom elevations
|
||
|
|
!
|
||
|
|
CALL ADDPTH2(NODLIST,NDLIST)
|
||
|
|
GO TO 220
|
||
|
|
|
||
|
|
ELSEIF (ANS .EQ. 'a') THEN
|
||
|
|
!
|
||
|
|
! All nodes
|
||
|
|
!
|
||
|
|
ISWT = -1
|
||
|
|
ELSEIF(ANS .EQ. 'f') THEN
|
||
|
|
!
|
||
|
|
! Fill nodes
|
||
|
|
!
|
||
|
|
ISWT = 0
|
||
|
|
! ELSEIF(ANS .EQ. 's') THEN
|
||
|
|
!
|
||
|
|
! Single node at a time
|
||
|
|
!
|
||
|
|
! ISWT = 1
|
||
|
|
|
||
|
|
!ipk feb02 add lock/unlock and remove cdata
|
||
|
|
|
||
|
|
! ELSEIF(ANS .EQ. 'w') THEN
|
||
|
|
!
|
||
|
|
! This option allows changes to nodal widths
|
||
|
|
!
|
||
|
|
! CALL ADDWID
|
||
|
|
! IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
! GO TO 100
|
||
|
|
!
|
||
|
|
! Call to help screen
|
||
|
|
!
|
||
|
|
ELSEIF(ANS .EQ. 'h') THEN
|
||
|
|
CALL HELPS(4)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
GO TO 100
|
||
|
|
!
|
||
|
|
ELSEIF(ANS .EQ. 'q') THEN
|
||
|
|
!
|
||
|
|
! Writeout and return
|
||
|
|
!
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
IF(IMP .EQ. 0) THEN
|
||
|
|
CALL SYMBL(0.,7.25,0.20,STRELS,0.,63)
|
||
|
|
go to 100
|
||
|
|
endif
|
||
|
|
!
|
||
|
|
! Establish size for range
|
||
|
|
!
|
||
|
|
!!!!!!!!!!!!!!!!!!!!!!!!!
|
||
|
|
|
||
|
|
IF(ISWTAGN .EQ. 0) THEN
|
||
|
|
|
||
|
|
! IF(IRECD .EQ. 2) THEN
|
||
|
|
! iswtintp=0
|
||
|
|
! iswtagn=0
|
||
|
|
! go to 210
|
||
|
|
! ENDIF
|
||
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to interpolate '//&
|
||
|
|
CHAR(13)//'from the triangulated map file?' ,&
|
||
|
|
'Select Interpolation method?')
|
||
|
|
! If answer 'Yes' set interpolate switch to 1
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(4) .EQ. 2) then
|
||
|
|
iswtintp=0
|
||
|
|
ELSE
|
||
|
|
iswtintp=1
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Ask this question again?'//&
|
||
|
|
CHAR(13)//' ' ,&
|
||
|
|
'Ask again?')
|
||
|
|
! If answer 'Yes' set again switch to 0
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(4) .EQ. 2) then
|
||
|
|
iswtagn=1
|
||
|
|
ELSE
|
||
|
|
iswtagn=0
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
210 CONTINUE
|
||
|
|
|
||
|
|
!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||
|
|
|
||
|
|
IF(ISWTINTP .EQ. 0) THEN
|
||
|
|
|
||
|
|
call setrng(xnears,nmap)
|
||
|
|
iswt=0
|
||
|
|
do n=1,ndlist
|
||
|
|
m=nodlist(n)
|
||
|
|
!ipk feb02
|
||
|
|
!ipk jan08 chnage subscript
|
||
|
|
if(lock(m) .eq. 0) CALL SETELV(XNEARS,NMAP,M,ISWT)
|
||
|
|
enddo
|
||
|
|
ELSE
|
||
|
|
if(nelts .eq. 0) then
|
||
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'No triangulated exists'//&
|
||
|
|
CHAR(13)//'Do you wish to triangulate now?' ,&
|
||
|
|
'NO TRIANGULATION AVAILABLE?')
|
||
|
|
! If answer 'Yes' set triangulate now
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(4) .EQ. 2) then
|
||
|
|
return
|
||
|
|
ELSE
|
||
|
|
call triang
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
endif
|
||
|
|
do n=1,ndlist
|
||
|
|
m=nodlist(n)
|
||
|
|
write(155,*) 'selt',m
|
||
|
|
!ipk mar20
|
||
|
|
if(iswt .eq. 0 .and. wd(m) .gt. -4400.) cycle
|
||
|
|
if(lock(m) .eq. 0) CALL TRIANINT(NMAP,M,ISWT,ITIME)
|
||
|
|
enddo
|
||
|
|
ENDIF
|
||
|
|
220 CONTINUE
|
||
|
|
|
||
|
|
elseif(ibox .eq. 4 .or. iflag .eq. 'l') then
|
||
|
|
|
||
|
|
! Define layers
|
||
|
|
|
||
|
|
call openlay
|
||
|
|
|
||
|
|
NHTP=0
|
||
|
|
NBRR=0
|
||
|
|
NMESS=45
|
||
|
|
CALL HEDR
|
||
|
|
NMESS=4
|
||
|
|
xprt=3.2
|
||
|
|
!
|
||
|
|
! call getint(nlay)
|
||
|
|
|
||
|
|
call GETLAYDAT(NLAY,ipos,RLAY)
|
||
|
|
ILAYTP=IPOS
|
||
|
|
|
||
|
|
do n=1,ndlist
|
||
|
|
j=nodlist(n)
|
||
|
|
lay(j)=nlay
|
||
|
|
DO I=1,NLAY
|
||
|
|
WTLAY(J,I)=RLAY(I)
|
||
|
|
ENDDO
|
||
|
|
enddo
|
||
|
|
REWIND 102
|
||
|
|
DO J=1,NP
|
||
|
|
IF(LAY(J) .GT. -9998) THEN
|
||
|
|
if(ILAYTP .eq. 1) then
|
||
|
|
write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||
|
|
6000 format('LD2 ',2i8,9F8.2)
|
||
|
|
else
|
||
|
|
write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||
|
|
6001 format('LD3 ',2i8,9F8.2)
|
||
|
|
endif
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
nlayd=1
|
||
|
|
!ipk feb02 add lcok/unlock
|
||
|
|
elseif(ibox .eq. 5 .or. iflag .eq. 'k') then
|
||
|
|
do n=1,ndlist
|
||
|
|
j=nodlist(n)
|
||
|
|
lock(j)=1
|
||
|
|
enddo
|
||
|
|
elseif(ibox .eq. 6 .or. iflag .eq. 'u') then
|
||
|
|
do n=1,ndlist
|
||
|
|
j=nodlist(n)
|
||
|
|
lock(j)=0
|
||
|
|
enddo
|
||
|
|
elseif(ibox .eq. 7 .or. iflag .eq. 'f') then
|
||
|
|
do n=1,np
|
||
|
|
list(n)=0
|
||
|
|
enddo
|
||
|
|
do n=1,ndlist
|
||
|
|
list(nodlist(n))=1
|
||
|
|
enddo
|
||
|
|
call deln2(np,0)
|
||
|
|
endif
|
||
|
|
|
||
|
|
! CALL PLOTOT(1)
|
||
|
|
|
||
|
|
nhtp=nhtps
|
||
|
|
nbrr=nbrs
|
||
|
|
nmess=nmessv
|
||
|
|
call hedr
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE SELELT(ISW)
|
||
|
|
|
||
|
|
USE BLK1MOD
|
||
|
|
save fracd
|
||
|
|
dimension xot(100),yot(100)
|
||
|
|
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
dimension nodlist(maxp)
|
||
|
|
character*1 iflag
|
||
|
|
|
||
|
|
data itime/0/
|
||
|
|
|
||
|
|
if(itime .eq. 0) then
|
||
|
|
mat=0
|
||
|
|
itime=1
|
||
|
|
endif
|
||
|
|
|
||
|
|
IF(ISW .EQ. 2) GO TO 200
|
||
|
|
|
||
|
|
CALL GETPOLY(XOT,YOT,NPTS)
|
||
|
|
|
||
|
|
|
||
|
|
!
|
||
|
|
! save nhtp etc
|
||
|
|
|
||
|
|
nhtps=nhtp
|
||
|
|
nbrs=nbrr
|
||
|
|
nmessv=nmess
|
||
|
|
|
||
|
|
! look for points inside polygon
|
||
|
|
|
||
|
|
ndlist=0
|
||
|
|
nefl=0
|
||
|
|
do n=1,ne
|
||
|
|
ieswt=0
|
||
|
|
if(ieskp(n) .eq. 0) then
|
||
|
|
ieswt=1
|
||
|
|
do m=1,ncorn(n)
|
||
|
|
j=nop(n,m)
|
||
|
|
if(j .gt. 0) then
|
||
|
|
inswt=0
|
||
|
|
call cpoly(xot,yot,npts,cord(j,1),cord(j,2),inswt)
|
||
|
|
if(inswt .eq. 1) then
|
||
|
|
! call rred
|
||
|
|
! fpn=j
|
||
|
|
! x = cord(j,1)
|
||
|
|
! y = cord(j,2) - .11
|
||
|
|
! call numbr(x,y,ht,fpn,0.0,-1)
|
||
|
|
ndlist=ndlist+1
|
||
|
|
nodlist(ndlist)=j
|
||
|
|
else
|
||
|
|
ieswt=0
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
if(ieswt .eq. 1) then
|
||
|
|
nefl=nefl+1
|
||
|
|
neflag(nefl)=n
|
||
|
|
! call rcyan
|
||
|
|
! fpn = n
|
||
|
|
! x = xc(n)
|
||
|
|
! y = yc(n) + .01
|
||
|
|
! call numbr(x,y,0.20,fpn,0.0,-1)
|
||
|
|
call fillem(n)
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
call rblue
|
||
|
|
|
||
|
|
GO TO 300
|
||
|
|
200 CONTINUE
|
||
|
|
!
|
||
|
|
! save nhtp etc
|
||
|
|
|
||
|
|
nhtps=nhtp
|
||
|
|
nbrs=nbrr
|
||
|
|
nmessv=nmess
|
||
|
|
NEFL=0
|
||
|
|
CALL GETFRAC(FRACD)
|
||
|
|
call plotot(0)
|
||
|
|
DO N=1,NE
|
||
|
|
IF(EDIF(N) .GT. (1.-FRACD)*EDIF(0)) THEN
|
||
|
|
nefl=nefl+1
|
||
|
|
neflag(nefl)=n
|
||
|
|
call fillem(n)
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
300 CONTINUE
|
||
|
|
if(isw .eq. 0 .OR. ISW .EQ. 2) then
|
||
|
|
nbrr=0
|
||
|
|
nhtp=15
|
||
|
|
call hedr
|
||
|
|
CALL XYLOC(xscrn1,yscrn1,iflag,ibox)
|
||
|
|
if(ibox .eq. 1 .or. iflag .eq. 'd') then
|
||
|
|
do n=1,nefl
|
||
|
|
j=neflag(n)
|
||
|
|
call deltel(j)
|
||
|
|
enddo
|
||
|
|
nefl=0
|
||
|
|
elseif(ibox .eq. 2 .or. iflag .eq. 'e') then
|
||
|
|
call refb
|
||
|
|
elseif(ibox .eq. 3 .or. iflag .eq. 't') then
|
||
|
|
nhtp=0
|
||
|
|
nbrr=4
|
||
|
|
NMESS=45
|
||
|
|
call hedr
|
||
|
|
nmess=2
|
||
|
|
call getint(mat)
|
||
|
|
ipsw(7)=1
|
||
|
|
ipsw(5)=0
|
||
|
|
do n=1,nefl
|
||
|
|
j=neflag(n)
|
||
|
|
imat(j) = mat
|
||
|
|
enddo
|
||
|
|
nefl=0
|
||
|
|
elseif(ibox .eq. 4 .or. iflag .eq. 'm') then
|
||
|
|
!
|
||
|
|
! simplify layout
|
||
|
|
!
|
||
|
|
IECHG=0
|
||
|
|
!IPK MAY03
|
||
|
|
ICHG=0
|
||
|
|
CALL SMFY
|
||
|
|
|
||
|
|
!ipk dec11
|
||
|
|
elseif(ibox .eq. 5 .or. iflag .eq. 'g') then
|
||
|
|
!
|
||
|
|
! form group
|
||
|
|
!
|
||
|
|
CALL FORMGP
|
||
|
|
|
||
|
|
endif
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
|
||
|
|
nhtp=nhtps
|
||
|
|
nbrr=nbrs
|
||
|
|
nmess=nmessv
|
||
|
|
call clrbox
|
||
|
|
call hedr
|
||
|
|
else
|
||
|
|
call extract(NODLIST,NDLIST)
|
||
|
|
|
||
|
|
! display extracted file
|
||
|
|
|
||
|
|
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
|
||
|
|
nhtp=nhtps
|
||
|
|
nbrr=nbrs
|
||
|
|
nmess=nmessv
|
||
|
|
call clrbox
|
||
|
|
call hedr
|
||
|
|
endif
|
||
|
|
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE CPOLY(XOT,YOT,NPTS,X,Y,INSWT)
|
||
|
|
DIMENSION XOT(*),YOT(*)
|
||
|
|
REAL*8 X,Y
|
||
|
|
DATA PI/3.14159/
|
||
|
|
SUMA=0
|
||
|
|
DO N=1,NPTS-1
|
||
|
|
ANG1=ATAN2(YOT(N+1)-Y,XOT(N+1)-X)
|
||
|
|
ANG2=ATAN2(YOT(N)-Y,XOT(N)-X)
|
||
|
|
DIFA=ANG2-ANG1
|
||
|
|
IF(ABS(DIFA) .GT. PI) THEN
|
||
|
|
IF(DIFA .LT. -PI) DIFA=DIFA+2.*PI
|
||
|
|
IF(DIFA .GT. PI) DIFA=DIFA-2.*PI
|
||
|
|
ENDIF
|
||
|
|
SUMA=SUMA+DIFA
|
||
|
|
ENDDO
|
||
|
|
IF(ABS(SUMA) .GT. PI) THEN
|
||
|
|
INSWT=1
|
||
|
|
ELSE
|
||
|
|
INSWT=0
|
||
|
|
ENDIF
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE GETPOLY(XOT,YOT,NPTS)
|
||
|
|
|
||
|
|
USE BLK1MOD
|
||
|
|
dimension xot(*),yot(*)
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
CHARACTER*23 SELN3
|
||
|
|
CHARACTER*32 SELN
|
||
|
|
CHARACTER*24 SELN2
|
||
|
|
CHARACTER*1 IFLAG
|
||
|
|
data SELN/' Click at points to form polygon'/
|
||
|
|
data SELN2/' Click next point '/
|
||
|
|
data SELN3/' Click last point again'/
|
||
|
|
|
||
|
|
80 CALL CLRBOX
|
||
|
|
nhtp=0
|
||
|
|
nbrr=5
|
||
|
|
nmess=0
|
||
|
|
call hedr
|
||
|
|
CALL SYMBL(0.,7.70,0.20,SELN,0.,32)
|
||
|
|
!
|
||
|
|
100 continue
|
||
|
|
!
|
||
|
|
! Get cursor location
|
||
|
|
!
|
||
|
|
CALL XYLOC(xscrn,yscrn,iflag,ibox)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
if (iflag .eq. 'q') return
|
||
|
|
!
|
||
|
|
if(iflag .eq. 'c') then
|
||
|
|
xot(1)=xscrn
|
||
|
|
yot(1)=yscrn
|
||
|
|
npts=1
|
||
|
|
!
|
||
|
|
! This option is creating an inset locations
|
||
|
|
!
|
||
|
|
120 continue
|
||
|
|
CALL XYLOC(xscrn1,yscrn1,iflag,ibox)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
if(ibox .eq. 6 .or. iflag .eq. 'b') then
|
||
|
|
npts=npts-1
|
||
|
|
go to 120
|
||
|
|
endif
|
||
|
|
if(iflag .eq. 'c') then
|
||
|
|
!
|
||
|
|
! Look for a screen size
|
||
|
|
!
|
||
|
|
122 continue
|
||
|
|
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 hedr
|
||
|
|
CALL SYMBL(0.,7.70,0.20,seln3,0.,23)
|
||
|
|
go to 120
|
||
|
|
endif
|
||
|
|
npts=npts+1
|
||
|
|
xot(npts)=xscrn1
|
||
|
|
yot(npts)=yscrn1
|
||
|
|
call DASHLN(xot,yot,npts,1)
|
||
|
|
CALL CLRBOX
|
||
|
|
call hedr
|
||
|
|
|
||
|
|
CALL SYMBL(0.,7.70,0.20,seln2,0.,24)
|
||
|
|
CALL XYLOC(xscrn1,yscrn1,iflag,ibox)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
|
||
|
|
if(ibox .eq. 6 .or. iflag .eq. 'b') then
|
||
|
|
npts=npts-1
|
||
|
|
go to 120
|
||
|
|
elseif(ibox .eq. 7 .or. iflag .eq. 'n') then
|
||
|
|
npts=npts+1
|
||
|
|
xot(npts)=xot(1)
|
||
|
|
yot(npts)=yot(1)
|
||
|
|
call DASHLN(xot,yot,npts,1)
|
||
|
|
go to 280
|
||
|
|
else
|
||
|
|
go to 122
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
ENDIF
|
||
|
|
280 continue
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
subroutine extract(NODLIST,NDLIST)
|
||
|
|
|
||
|
|
USE WINTERACTER
|
||
|
|
USE BLK1MOD
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
! include 'blk1.com'
|
||
|
|
|
||
|
|
|
||
|
|
include 'd.inc'
|
||
|
|
|
||
|
|
DIMENSION NODLIST(*)
|
||
|
|
CHARACTER(LEN=256) :: FILTER
|
||
|
|
CHARACTER(LEN=255) :: FNAME,FNAMRM
|
||
|
|
|
||
|
|
! select filename for new file
|
||
|
|
|
||
|
|
FILTER ="Rm1 file -- *.rm1|*.rm1|"
|
||
|
|
CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Filename for extracted file')
|
||
|
|
|
||
|
|
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||
|
|
GO TO 200
|
||
|
|
ELSE
|
||
|
|
GO TO 500
|
||
|
|
ENDIF
|
||
|
|
200 CONTINUE
|
||
|
|
CALL IlowerCase(FNAME)
|
||
|
|
|
||
|
|
ITOTFIL=ITOTFIL+1
|
||
|
|
FNAMEOUT(ITOTFIL)=FNAME
|
||
|
|
|
||
|
|
! save current file
|
||
|
|
|
||
|
|
IFILOUT=IACTVFIL+50
|
||
|
|
CALL WRTFIL(IFILOUT)
|
||
|
|
|
||
|
|
! create network structure
|
||
|
|
|
||
|
|
CALL ZERORELM(NODLIST,NDLIST)
|
||
|
|
|
||
|
|
IACTVFIL=ITOTFIL
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
! save new structure
|
||
|
|
|
||
|
|
IOT = 20
|
||
|
|
FNAMRM=FNAME
|
||
|
|
igfgsw=0
|
||
|
|
close(iot)
|
||
|
|
OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN')
|
||
|
|
!
|
||
|
|
! Check if file cords format to be short or long
|
||
|
|
!
|
||
|
|
!
|
||
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to save'//&
|
||
|
|
CHAR(13)//'coordinates in long format?' ,&
|
||
|
|
'Coordinate save format')
|
||
|
|
!
|
||
|
|
! If answer 'No', use short format
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(4) .EQ. 2) then
|
||
|
|
ntempin=0
|
||
|
|
else
|
||
|
|
ntempin=2
|
||
|
|
END IF
|
||
|
|
!
|
||
|
|
call wrtout(1)
|
||
|
|
CLOSE (IOT)
|
||
|
|
OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN')
|
||
|
|
|
||
|
|
500 continue
|
||
|
|
return
|
||
|
|
end
|
||
|
|
|
||
|
|
SUBROUTINE ZERORELM(NODLIST,NDLIST)
|
||
|
|
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
dimension nodlist(*)
|
||
|
|
|
||
|
|
DO N=1,NP
|
||
|
|
|
||
|
|
! search nodlist
|
||
|
|
|
||
|
|
do k=1,ndlist
|
||
|
|
if(n .eq. nodlist(K)) go to 300
|
||
|
|
enddo
|
||
|
|
call deletn(n)
|
||
|
|
300 continue
|
||
|
|
ENDDO
|
||
|
|
|
||
|
|
! reset NP
|
||
|
|
|
||
|
|
do k=np,1,-1
|
||
|
|
if(inew(k) .gt. 0) then
|
||
|
|
np=k
|
||
|
|
go to 350
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
350 continue
|
||
|
|
|
||
|
|
! reset NE
|
||
|
|
|
||
|
|
do k=ne,1,-1
|
||
|
|
if(imat(k) .gt. 0) then
|
||
|
|
ne=k
|
||
|
|
go to 400
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
400 continue
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE GETFRAC(FRACD)
|
||
|
|
!
|
||
|
|
! Generate continuity lines
|
||
|
|
!
|
||
|
|
|
||
|
|
USE WINTERACTER
|
||
|
|
save
|
||
|
|
include 'd.inc'
|
||
|
|
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
integer :: I1,I2,I3,ITIME,IPOS
|
||
|
|
|
||
|
|
REAL :: FRACD
|
||
|
|
|
||
|
|
data itime/0/
|
||
|
|
|
||
|
|
IF(ITIME .EQ. 0) THEN
|
||
|
|
FRACD=0.1
|
||
|
|
itime=1
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
call wdialogload(IDD_SETSEL)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_SETSEL)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogPutReal(IDF_REAL1,FRACD)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
do
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
|
||
|
|
CALL WDialoggetReal(IDF_REAL1,FRACD)
|
||
|
|
GO TO 100
|
||
|
|
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
enddo
|
||
|
|
|
||
|
|
100 CONTINUE
|
||
|
|
return
|
||
|
|
end
|
||
|
|
|
||
|
|
SUBROUTINE FINDTYP
|
||
|
|
|
||
|
|
USE WINTERACTER
|
||
|
|
USE BLKMAP
|
||
|
|
USE BLK1MOD
|
||
|
|
USE BLK2MOD
|
||
|
|
character*1 iflag
|
||
|
|
|
||
|
|
include 'd.inc'
|
||
|
|
|
||
|
|
DATA NS/1/
|
||
|
|
|
||
|
|
|
||
|
|
call wdialogload(IDD_SELELTYP)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogPutInteger(IDF_INTEGER1,NS)
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_SELELTYP)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,ModaL)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
do
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
CALL WDialogGetInteger(IDF_INTEGER1,NS)
|
||
|
|
go to 80
|
||
|
|
ENDIF
|
||
|
|
enddo
|
||
|
|
80 CONTINUE
|
||
|
|
ICLL=4
|
||
|
|
call clscrn
|
||
|
|
call plotot(0)
|
||
|
|
nefl=0
|
||
|
|
DO N=1,NE
|
||
|
|
IF(IMAT(N) .EQ. NS) THEN
|
||
|
|
CALL FILLEMC(N,ICLL)
|
||
|
|
nefl=nefl+1
|
||
|
|
neflag(nefl)=n
|
||
|
|
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
nbrr=0
|
||
|
|
nhtp=15
|
||
|
|
call hedr
|
||
|
|
CALL XYLOC(xscrn1,yscrn1,iflag,ibox)
|
||
|
|
if(ibox .eq. 1 .or. iflag .eq. 'd') then
|
||
|
|
do n=1,nefl
|
||
|
|
j=neflag(n)
|
||
|
|
call deltel(j)
|
||
|
|
enddo
|
||
|
|
nefl=0
|
||
|
|
elseif(ibox .eq. 2 .or. iflag .eq. 'e') then
|
||
|
|
call refb
|
||
|
|
elseif(ibox .eq. 3 .or. iflag .eq. 't') then
|
||
|
|
nhtp=0
|
||
|
|
nbrr=4
|
||
|
|
NMESS=45
|
||
|
|
call hedr
|
||
|
|
nmess=2
|
||
|
|
call getint(mat)
|
||
|
|
ipsw(7)=1
|
||
|
|
ipsw(5)=0
|
||
|
|
do n=1,nefl
|
||
|
|
j=neflag(n)
|
||
|
|
imat(j) = mat
|
||
|
|
enddo
|
||
|
|
nefl=0
|
||
|
|
elseif(ibox .eq. 4 .or. iflag .eq. 'm') then
|
||
|
|
!
|
||
|
|
! simplify layout
|
||
|
|
!
|
||
|
|
IECHG=0
|
||
|
|
!IPK MAY03
|
||
|
|
ICHG=0
|
||
|
|
CALL SMFY
|
||
|
|
|
||
|
|
!ipk dec11
|
||
|
|
elseif(ibox .eq. 5 .or. iflag .eq. 'g') then
|
||
|
|
!
|
||
|
|
! form group
|
||
|
|
!
|
||
|
|
CALL FORMGP
|
||
|
|
|
||
|
|
elseif(ibox .eq. 6) then
|
||
|
|
do n=1,nefl
|
||
|
|
j=neflag(n)
|
||
|
|
do jj=1,8
|
||
|
|
if(nop(j,jj) .ne. 0) then
|
||
|
|
wd(nop(j,jj))=-9999.
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE MVGRP(NDLIST,NODLIST)
|
||
|
|
|
||
|
|
USE WINTERACTER
|
||
|
|
USE BLK1MOD
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
dimension nodlist(maxp),RLAY(9)
|
||
|
|
character*1 iflag
|
||
|
|
! GET AMOUNT OF SHIFT IN PAGE UNITS
|
||
|
|
200 continue
|
||
|
|
NHTP = 16
|
||
|
|
NMESS = 47
|
||
|
|
NBRR = 0
|
||
|
|
CALL HEDR
|
||
|
|
CALL xyloc(xscrn1,yscrn1,iflag,ibox)
|
||
|
|
CALL XYLOC(XSCRN2,YSCRN2,IFLAG,IBOX)
|
||
|
|
XSHIFT=XSCRN2-XSCRN1
|
||
|
|
YSHIFT=YSCRN2-YSCRN1
|
||
|
|
! APPLY SHIFT TO NODES IN THE LIST
|
||
|
|
DO N=1,NDLIST
|
||
|
|
CORD(NODLIST(N),1)=CORD(NODLIST(N),1)+XSHIFT
|
||
|
|
CORD(NODLIST(N),2)=CORD(NODLIST(N),2)+YSHIFT
|
||
|
|
ENDDO
|
||
|
|
CALL PLOTOT(0)
|
||
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to save'//&
|
||
|
|
CHAR(13)//'new coordinate location?' ,&
|
||
|
|
'COORDINATE MOVE')
|
||
|
|
IF (WInfoDialog(4) .EQ. 2) then
|
||
|
|
! revert to old
|
||
|
|
DO N=1,NDLIST
|
||
|
|
CORD(NODLIST(N),1)=(XUSR(NODLIST(N))+XS)/TXSCAL
|
||
|
|
CORD(NODLIST(N),2)=(YUSR(NODLIST(N))+YS)/TXSCAL
|
||
|
|
ENDDO
|
||
|
|
CALL PLOTOT(0)
|
||
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to '//&
|
||
|
|
CHAR(13)//'try again?' ,&
|
||
|
|
'COORDINATE MOVE')
|
||
|
|
IF (WInfoDialog(4) .EQ. 2) then
|
||
|
|
return
|
||
|
|
else
|
||
|
|
go to 200
|
||
|
|
endif
|
||
|
|
else
|
||
|
|
! accept
|
||
|
|
END IF
|
||
|
|
RETURN
|
||
|
|
END
|