! 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