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.
885 lines
33 KiB
Fortran
885 lines
33 KiB
Fortran
!IPK LAST UPDATE FEB 11 2002 ADD LOCK AS VARIABLE
|
|
!ipk last update Feb 10 1997
|
|
SUBROUTINE GRIDSB(ISWTIN)
|
|
!
|
|
! Routines to control interpolation of nodal elevations
|
|
!
|
|
USE WINTERACTER
|
|
USE BLKMAP
|
|
USE BLK1MOD
|
|
|
|
include 'd.inc'
|
|
|
|
! INCLUDE 'BLK1.COM'
|
|
|
|
INCLUDE 'TXFRM.COM'
|
|
|
|
!iPK APR94
|
|
COMMON /RECOD/ IRECD,TSPC
|
|
|
|
|
|
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
|
!
|
|
!IPKJAN94 INTEGER*2 LISTM
|
|
! INTEGER LISTM
|
|
!ipk feb94 add ARF then remove may97
|
|
|
|
! DIMENSION LISTM(1000),listt(1600,4),nlf(4),icomp(4),xnear(4)
|
|
!ipk feb03 common /mapc/imap(maxpl),NCRS(MAXPL)
|
|
!ipk sep97 add NCRS above
|
|
!
|
|
!ipknov93 CHARACTER*1 ANS,ANSW(10)
|
|
CHARACTER*1 ANS,ANSW(10),IFLAG
|
|
CHARACTER*63 STRELS
|
|
DATA STRELS/' You have tried set to set elevation with no mapfile"'/
|
|
!
|
|
DATA ANSW/'m','a','f','s','k','u','t','w','h','q'/
|
|
!JUN08 DATA ISWTAGN/0/
|
|
!ipk feb94 add DATA and FUNCTION below
|
|
! DATA ARF/-180.,-90.,0.,90.,180./
|
|
! ANGN(K,L)=
|
|
! + ATAN2((CMAP(K,2)-CORD(L,2)),(CMAP(K,1)-CORD(L,1)))*57.296
|
|
!
|
|
! Draw box around selections
|
|
!
|
|
!IPK SEP97
|
|
100 CONTINUE
|
|
IDONET=0
|
|
NHTP = 9
|
|
NMESS = 0
|
|
NBRR = 0
|
|
IERREL=0
|
|
IF(ISWTIN .EQ. -1) GO TO 190
|
|
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 ADDPTH
|
|
IF(IRMAIN .EQ. 1) RETURN
|
|
GO TO 100
|
|
|
|
ELSEIF (ANS .EQ. 'a') THEN
|
|
!
|
|
! All nodes
|
|
!
|
|
ISWT = -1
|
|
DO N=1,NP
|
|
IF(INEW(N) .EQ. 1) WD(N)=-9999.
|
|
ENDDO
|
|
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. 'k') THEN
|
|
!
|
|
! lock node
|
|
!
|
|
! Get M from mouse
|
|
!
|
|
115 CONTINUE
|
|
NHTP=0
|
|
NMESS=21
|
|
NBRR=3
|
|
CALL HEDR
|
|
IBOX=1
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,M,IFLAG,INSKP,IBOX)
|
|
IF(IRMAIN .EQ. 1) RETURN
|
|
if(iflag .eq. 'q') go to 100
|
|
lock(m)=1
|
|
go to 115
|
|
ELSEIF(ANS .EQ. 'u') THEN
|
|
!
|
|
! unlock node
|
|
!
|
|
! Get M from mouse
|
|
!
|
|
120 CONTINUE
|
|
NHTP=0
|
|
NMESS=21
|
|
NBRR=3
|
|
CALL HEDR
|
|
IBOX=1
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,M,IFLAG,INSKP,IBOX)
|
|
IF(IRMAIN .EQ. 1) RETURN
|
|
if(iflag .eq. 'q') go to 100
|
|
lock(m)=0
|
|
go to 120
|
|
ELSEIF(ANS .EQ. 't') THEN
|
|
!
|
|
! Create data for layers
|
|
!
|
|
CALL ADDLAY
|
|
IF(IRMAIN .EQ. 1) RETURN
|
|
GO TO 100
|
|
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
|
|
|
|
190 CONTINUE
|
|
|
|
IF(IMP .EQ. 0) THEN
|
|
CALL SYMBL(0.,7.25,0.20,STRELS,0.,63)
|
|
go to 100
|
|
endif
|
|
!
|
|
! Establish size for range
|
|
!
|
|
call setrng(xnears,nmap)
|
|
|
|
ITIME=0
|
|
ICOUNTF=0
|
|
MM=0
|
|
200 MM=MM+1
|
|
! write(90,*) 'gridsb-111',mm,np,iswt,inew(mm)
|
|
IF(MM .LE. NP) THEN
|
|
!
|
|
! Decode which alternative we are processing
|
|
! ipk feb 03 determine interpolation method
|
|
!
|
|
IF(MM .EQ. 1 .AND. ISWTAGN .EQ. 0) THEN
|
|
|
|
IF(IRECD .EQ. 2) THEN
|
|
iswtintp=0
|
|
iswtagn=0
|
|
go to 210
|
|
ENDIF
|
|
IF(IGUNIT .EQ. 203) THEN
|
|
ISWTINTP=1
|
|
iswtagn=1
|
|
GO TO 210
|
|
ENDIF
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to interpolate '//&
|
|
CHAR(13)//'from the triangulated map file?'//&
|
|
'or from a grid 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. 1 .AND. IGUNIT .NE. 203) then
|
|
if(iswt .ne. 1) then
|
|
|
|
! Sort the x-coordinates
|
|
|
|
call sortdb(xusr,ncrs,np)
|
|
else
|
|
ncrs(mm)=mm
|
|
endif
|
|
m=ncrs(mm)
|
|
else
|
|
m=mm
|
|
endif
|
|
! IPK OCT 2 1991
|
|
IF(ISWT .EQ. 1) THEN
|
|
! Single node at a time ISWT = 1
|
|
!
|
|
! Get M from mouse and set MM to NP
|
|
!
|
|
NHTP=0
|
|
NMESS=21
|
|
!ipk jun08 NBRR=0
|
|
NBRR=1
|
|
CALL HEDR
|
|
IBOX=1
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
|
IF(IRMAIN .EQ. 1) RETURN
|
|
if(iflag .eq. 'q') go to 100
|
|
M=INODE
|
|
MM=NP
|
|
endif
|
|
IF(INEW(M) .EQ. 0) GO TO 200
|
|
! IPK END OCT 2 1991
|
|
|
|
IF(ISWT .EQ. -1) THEN
|
|
! All nodes ISWT = -1
|
|
!ipk feb02
|
|
if(lock(m) .eq. 1) go to 200
|
|
|
|
ELSEIF(ISWT .EQ. 0) THEN
|
|
! Fill nodes ISWT = 0
|
|
!ipk feb02
|
|
IF(WD(M) .GT. -9000. .or. lock(m) .eq. 1) go to 200
|
|
|
|
ENDIF
|
|
! write(90,*) 'gridsb-138', m,mm,iswt,wd(m),xnears
|
|
|
|
IF(ISWTINTP .EQ. 0) THEN
|
|
if(lock(m) .eq. 0) CALL SETELV(XNEARS,NMAP,M,ISWT)
|
|
ELSE
|
|
if(nelts .eq. 0 .and. igunit .ne. 203) 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
|
|
IDONET=1
|
|
ENDIF
|
|
|
|
endif
|
|
if(lock(m) .eq. 0) then
|
|
if(igunit .ne. 203) then
|
|
CALL TRIANINT(NMAP,M,ISWT,ITIME)
|
|
else
|
|
call GETGRDELEV(M,IERREL)
|
|
endif
|
|
endif
|
|
ENDIF
|
|
|
|
! write(90,*) 'gridsb-141', m,iswt,wd(m)
|
|
if(wd(m) .lt. -9997.) THEN
|
|
icountf=icountf+1
|
|
WD(M)=-9998.
|
|
ENDIF
|
|
GO TO 200
|
|
ENDIF
|
|
IF(IDONET .EQ. 1) THEN
|
|
CALL RDMAP(2,99,0,0) ! XXXXX
|
|
CLOSE(99)
|
|
ENDIF
|
|
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to plot contours?'//&
|
|
CHAR(13)//' ','PLOT CONTOURS?')
|
|
!
|
|
! If answer 'No', return
|
|
!
|
|
IF (WInfoDialog(4).EQ.2) THEN
|
|
go to 220
|
|
ENDIF
|
|
215 menus=13
|
|
call conout(menus)
|
|
MENUS=12
|
|
CALL CONOUT(MENUS)
|
|
|
|
!ipkjan94 IF(ISWT .EQ. -1) GO TO 210
|
|
220 if(icountf .gt. 0) then
|
|
|
|
CALL FMESS(ICOUNTF,ISWTT)
|
|
!
|
|
! If answer 'Yes', use search for adjacent nodes
|
|
!
|
|
IF(ISWTT .EQ. 1) then
|
|
call fillin(icountf)
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to plot contours again?'//&
|
|
CHAR(13)//' ','PLOT CONTOURS?')
|
|
!
|
|
! If answer 'No', return
|
|
!
|
|
IF (WInfoDialog(4).EQ.2) THEN
|
|
IF(ICOUNTF .GT. 0) GO TO 220
|
|
ELSE
|
|
GO TO 215
|
|
ENDIF
|
|
END IF
|
|
endif
|
|
IF(ISWTIN .EQ. -1) RETURN
|
|
IF(ISWT .EQ. 1) THEN
|
|
!ipk jun08 CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
|
IF(IRMAIN .EQ. 1) RETURN
|
|
if(iflag .eq. 'q') go to 100
|
|
M=INODE
|
|
MM=NP-1
|
|
GO TO 200
|
|
ELSEIF(ISWT .EQ. -1) THEN
|
|
GO TO 100
|
|
ENDIF
|
|
!ipk jun08 IF(ABS(ISWT) .EQ. 1) GO TO 100
|
|
RETURN
|
|
END
|
|
!ipk jul98 revise call
|
|
!IPK SUBROUTINE GRIDIN(I,SOLN,LISTM,NLG)
|
|
SUBROUTINE GRIDIN(XZ,YZ,SOLN,LISTM,NLG)
|
|
!
|
|
! Routine to interpolate values from map to node points
|
|
!
|
|
! I is the location in the CORD array to be interpolated
|
|
! SOLN is the interpolated value developed
|
|
! NLG is the number of entries in the map array
|
|
|
|
USE BLKMAP
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
|
|
!IPK JAN94 INTEGER*2 LISTM,NLIST,NKEY
|
|
!IPK DEC09 INTEGER LISTM,NLIST,NKEY
|
|
INTEGER LISTM,NLIST
|
|
DIMENSION LISTM(*)
|
|
DIMENSION NLIST(1000),ADIST(1000),WT(1000)
|
|
!
|
|
! Function statements
|
|
!
|
|
DIST(K,X,Y)=SQRT((CMAP(K,1)-X)**2+(CMAP(K,2)-Y)**2)
|
|
!IPK FEB97 ANG(K,X,Y)=ATAN2((CMAP(K,2)-Y),(CMAP(K,1)-X))*57.296
|
|
ANG(K,X,Y)=ATAN2((CMAP(K,1)-X),(CMAP(K,2)-Y))*57.296
|
|
!
|
|
! Initialize
|
|
!
|
|
TOL=120.
|
|
! DO KK=1,NLG
|
|
! WRITE(90,*) 'LISTM',KK,LISTM(KK)
|
|
! ENDDO
|
|
!
|
|
! Form list of distances from I to data locations
|
|
!
|
|
NTMP=0
|
|
IPAS=1
|
|
!IPK JUL98 X=CORD(I,1)
|
|
!PK JUL98 Y=CORD(I,2)
|
|
X=XZ
|
|
Y=YZ
|
|
140 CONTINUE
|
|
DO 150 KK=1,NLG
|
|
K=LISTM(KK)
|
|
IF(K .EQ. NTMP) THEN
|
|
ADIST(KK)=-VOID
|
|
ELSE
|
|
ADIST(KK)=DIST(K,X,Y)
|
|
ENDIF
|
|
150 END DO
|
|
!
|
|
! Sort order for nearest points
|
|
!
|
|
CALL SORT(ADIST,NKEY,NLG)
|
|
do nnnn=1,nlg
|
|
nn=nkey(nnnn)
|
|
nzz=listm(nn)
|
|
WRITE(90,*) NZZ,X,Y,cmap(nzz,1),cmap(nzz,2)
|
|
ATMP=ANG(NZZ,X,Y)
|
|
write(90,*) nnnn,adist(nnnn),val(nzz),ATMP
|
|
enddo
|
|
! read(*,*) aaa
|
|
KK=1
|
|
!
|
|
! Search through sorted list
|
|
!
|
|
INIT=1
|
|
180 DO 260 K=1,NLG
|
|
NN=NKEY(K)
|
|
IF(NN .EQ. 0) GO TO 260
|
|
N=LISTM(NN)
|
|
!
|
|
! Initialize
|
|
!
|
|
IF(N .EQ. NTMP) GO TO 260
|
|
IF(INIT .EQ. 1) THEN
|
|
NLIST(1)=N
|
|
YY=(CMAP(N,2)-Y)
|
|
XX=(CMAP(N,1)-X)
|
|
IF(YY .EQ. 0. .AND. XX .EQ. 0.) THEN
|
|
RANGEF=0.
|
|
RANGEB=360.
|
|
ELSE
|
|
RANGEF=ANG(N,X,Y)
|
|
RANGEB=ANG(N,X,Y)+360.
|
|
ENDIF
|
|
INIT=2
|
|
GO TO 260
|
|
ENDIF
|
|
!
|
|
! Skip out if already processed
|
|
!
|
|
YY=(CMAP(N,2)-Y)
|
|
XX=(CMAP(N,1)-X)
|
|
IF(YY .EQ. 0. .AND. XX .EQ. 0.) THEN
|
|
ANGLE=0.
|
|
ELSE
|
|
ANGLE=ANG(N,X,Y)
|
|
ENDIF
|
|
200 CONTINUE
|
|
! write(90,*) 'angls',n,angle,rangef,rangeb,val(n)
|
|
!
|
|
! Test if angle greater than high value
|
|
!
|
|
IF(ANGLE .GT. RANGEF) THEN
|
|
!
|
|
! Test if the new point is within the allowable range
|
|
!
|
|
IF(ANGLE .LT. RANGEF+TOL) THEN
|
|
!
|
|
! Process this point
|
|
!
|
|
RANGEF=ANGLE
|
|
KK=KK+1
|
|
NLIST(KK)=N
|
|
NKEY(K)=0
|
|
!
|
|
! Test if we now have enough points to exit
|
|
!
|
|
IF(RANGEF+TOL .GT. RANGEB) THEN
|
|
GO TO 300
|
|
ELSE
|
|
GO TO 180
|
|
ENDIF
|
|
!
|
|
! Test if angle lies inside the already spanned area
|
|
! If so it cannot be used
|
|
!
|
|
ELSEIF(ANGLE .GT. RANGEB) THEN
|
|
NKEY(K)=0
|
|
!
|
|
! Test if it close enough to the low value
|
|
!
|
|
ELSEIF(ANGLE .GT. RANGEB-TOL) THEN
|
|
!
|
|
! Process this point
|
|
!
|
|
RANGEB=ANGLE
|
|
KK=KK+1
|
|
NLIST(KK)=N
|
|
NKEY(K)=0
|
|
!
|
|
! Test if we have enough points to exit
|
|
!
|
|
IF(RANGEF+TOL .GT. RANGEB) THEN
|
|
GO TO 300
|
|
ELSE
|
|
GO TO 180
|
|
ENDIF
|
|
!
|
|
! Not a usable point at this time, move on to next point
|
|
!
|
|
ELSE
|
|
GO TO 260
|
|
!
|
|
! Increase angle by 360 and test again
|
|
!
|
|
ENDIF
|
|
ELSE
|
|
ANGLE=ANGLE+360.
|
|
GO TO 200
|
|
ENDIF
|
|
260 END DO
|
|
!
|
|
! We have finished loop without completing polygon
|
|
!
|
|
GO TO 500
|
|
!
|
|
! Process least squares fit on this list
|
|
!
|
|
300 CONTINUE
|
|
! WRITE(90,*) 'least squares list',KK,x,y
|
|
! WRITE(90,*) (NLIST(N),N=1,KK)
|
|
! do n=1,kk
|
|
! write(90,*) nlist(n),cmap(nlist(n),1),cmap(nlist(n),2)
|
|
! + ,val(nlist(n)),dist(nlist(n),x,y)
|
|
! enddo
|
|
!ipk feb97 changes to refine processing
|
|
!
|
|
! Check if points are close together relative to the centre point
|
|
!
|
|
! write(90,*) kk,x,y,nlg
|
|
do n=1,kk
|
|
l=nlist(n)
|
|
dc=dist(l,x,y)
|
|
xx=cmap(l,1)
|
|
yy=cmap(l,2)
|
|
if(n .lt. kk) then
|
|
do m=n+1,kk
|
|
ll=nlist(m)
|
|
dr=dist(ll,xx,yy)
|
|
if(dr .lt. 0.1*dc) then
|
|
if(kk .gt. 3) then
|
|
ds=dist(ll,x,y)
|
|
if(ds .lt. dc) then
|
|
ndrp=n
|
|
else
|
|
ndrp=m
|
|
endif
|
|
!
|
|
! drop this point
|
|
!
|
|
do mm=ndrp,kk-1
|
|
nlist(mm)=nlist(mm+1)
|
|
enddo
|
|
kk=kk-1
|
|
go to 300
|
|
else
|
|
go to 310
|
|
endif
|
|
endif
|
|
enddo
|
|
endif
|
|
enddo
|
|
310 continue
|
|
!ipk feb97 end changes for processing
|
|
! WRITE(90,*) '310',kk
|
|
! WRITE(90,*) (NLIST(N),N=1,KK)
|
|
!ipk feb97 chnage to add weighting
|
|
do n=1,kk
|
|
!ipk jul98 if(dist(nlist(n),CORD(I,1),CORD(I,2)) .gt. 0.) then
|
|
!ipk jul98 wt(n)=1./dist(nlist(n),CORD(I,1),CORD(I,2))
|
|
if(dist(nlist(n),XZ,YZ) .gt. 0.) then
|
|
wt(n)=1./dist(nlist(n),XZ,YZ)
|
|
else
|
|
soln=val(nlist(n))
|
|
return
|
|
endif
|
|
enddo
|
|
!IPK JUL98 CALL ALSQ(KK,NLIST,I,SOLN,WT)
|
|
CALL ALSQ(KK,NLIST,XZ,YZ,SOLN,WT)
|
|
!ipk feb97 end changes
|
|
!
|
|
! final value is SOLN
|
|
!
|
|
RETURN
|
|
500 TOL=TOL+25.
|
|
IF(TOL .GT. 180.) GO TO 550
|
|
IF(RANGEF+TOL .GT. RANGEB) THEN
|
|
GO TO 300
|
|
ENDIF
|
|
GO TO 180
|
|
550 CONTINUE
|
|
!c write(90,*) ' in trouble split',rangef,rangeb
|
|
SPLIT=(RANGEF+RANGEB)/2.-180.
|
|
AMIN=180.
|
|
DO 600 N=1,KK
|
|
IF(NLIST(N) .EQ. NTMP) GO TO 600
|
|
YY=(CMAP(NLIST(N),2)-Y)
|
|
XX=(CMAP(NLIST(N),1)-X)
|
|
IF(YY .EQ. 0. .AND. XX .EQ. 0.) THEN
|
|
ANGL=0.
|
|
ELSE
|
|
ANGL=ANG(NLIST(N),X,Y)
|
|
ENDIF
|
|
IF(IPAS .EQ. 2) GO TO 600
|
|
!
|
|
! Find line closest to split
|
|
!
|
|
IF(ABS(SPLIT-ANGL) .LT. AMIN) THEN
|
|
AMIN=ABS(SPLIT-ANGL)
|
|
! write(90,*) 'ntmp reset',ntmp,nlist(n),amin,split
|
|
NTMP=NLIST(N)
|
|
ENDIF
|
|
ANGLP=ANGL-360.
|
|
IF(ABS(SPLIT-ANGLP) .LT. AMIN) THEN
|
|
AMIN=ABS(SPLIT-ANGLP)
|
|
NTMP=NLIST(N)
|
|
ENDIF
|
|
! 580 WRITE(90,*) NLIST(N),ANGL
|
|
600 END DO
|
|
IF(IPAS .EQ. 1) THEN
|
|
IPAS=2
|
|
X=CMAP(NTMP,1)
|
|
Y=CMAP(NTMP,2)
|
|
TOL=120.
|
|
write(90,*) 'INTERP FOR ',xz,yz,' MOVED TO',x,y,ntmp
|
|
GO TO 140
|
|
ENDIF
|
|
WRITE(90,*) 'ERROR NO POLYGON RANGEF,RANGEB',RANGEF,RANGEB,SPLIT
|
|
WRITE(90,*) 'OPPOSITE NODE AND ANGULAR DIFF',NTMP,AMIN
|
|
SOLN=-9998.
|
|
RETURN
|
|
END
|
|
!
|
|
! FUNCTION ANG(K,X,Y)
|
|
!
|
|
! INCLUDE 'BLK1.COM'
|
|
!
|
|
! YY=(CMAP(K,2)-Y)
|
|
! XX=(CMAP(K,1)-X)
|
|
! IF(YY .EQ. 0. .AND. XX .EQ. 0.) THEN
|
|
! ANG=0.
|
|
! ELSE
|
|
! ANG=ATAN2(YY,XX)*57.296
|
|
! ENDIF
|
|
! RETURN
|
|
! END
|
|
|
|
SUBROUTINE SORT(A,NKEY,N)
|
|
!*********************************** .....SORT.....
|
|
!-
|
|
!......SORT IS A SIMPLE SHELL SORT ROUTINE
|
|
!-
|
|
! SHELL SORT
|
|
SAVE
|
|
!
|
|
!IPK JAN94 INTEGER*2 NKEY
|
|
DIMENSION A(*),NKEY(1)
|
|
IF(N.LT.2) RETURN
|
|
DO 90 J=1,N
|
|
NKEY(J)=J
|
|
90 END DO
|
|
ID = N
|
|
100 ID = ID / 2
|
|
110 IB = 1
|
|
120 GO TO 200
|
|
130 IB = IB + 1
|
|
IF( IB .LE. ID ) GO TO 200
|
|
IF( ID .GT. 1 ) GO TO 100
|
|
RETURN
|
|
200 I = IB
|
|
210 K = I + ID
|
|
220 IF( A(NKEY(I)) .LE. A(NKEY(K)) ) GO TO 250
|
|
NKT = NKEY(K)
|
|
NKEY(K) = NKEY(I)
|
|
J = I
|
|
230 K = J - ID
|
|
IF( K .LT. 1 ) GO TO 240
|
|
IF( A(NKT) .GT. A(NKEY(K)) ) GO TO 240
|
|
NKEY(J) = NKEY(K)
|
|
J = K
|
|
GO TO 230
|
|
240 NKEY(J) = NKT
|
|
250 I = I + ID
|
|
IF( I + ID .LE. N ) GO TO 210
|
|
GO TO 130
|
|
END
|
|
!ipk feb97 add weighting
|
|
!iok jul98 SUBROUTINE ALSQ(NPTS,NLIST,I,SOLN,WT)
|
|
SUBROUTINE ALSQ(NPTS,NLIST,xx,yy,SOLN,WT)
|
|
!
|
|
! Least squares routine
|
|
!
|
|
! INCLUDE 'PARAM.COM'
|
|
USE BLKMAP
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
!IPK JAN94 INTEGER*2 NLIST
|
|
REAL*8 A,R,B,S,X,Y,ATR,ATR2,BTR,C,T,X3,X2,X1
|
|
DIMENSION A(3,3),R(3),B(2,2),S(2),wt(*)
|
|
DIMENSION NLIST(*)
|
|
!
|
|
! Initialize matrices
|
|
!
|
|
!ipk jul98 X=CORD(I,1)
|
|
!ipk jul98 Y=CORD(I,2)
|
|
X=XX
|
|
Y=YY
|
|
! write(*,*) (nnn,cmap(nnn,1),cmap(nnn,2),nnn=1,16)
|
|
! write(*,*) (nlist(n),n=1,npts)
|
|
DO 160 K=1,3
|
|
R(K)=0.
|
|
DO 150 J=1,3
|
|
A(J,K)=0.
|
|
150 CONTINUE
|
|
160 END DO
|
|
!
|
|
! Form A and R matrices
|
|
!
|
|
DO 200 N=1,NPTS
|
|
KK=NLIST(N)
|
|
! write(*,*) cmap(kk,1),cmap(kk,2),val(kk)
|
|
!ipk feb97 add weighting
|
|
A(1,1)=A(1,1)+1.0*wt(n)
|
|
A(1,2)=A(1,2)+CMAP(KK,1)*wt(n)
|
|
A(1,3)=A(1,3)+CMAP(KK,2)*wt(n)
|
|
A(2,2)=A(2,2)+CMAP(KK,1)**2*wt(n)
|
|
A(2,3)=A(2,3)+CMAP(KK,1)*CMAP(KK,2)*wt(n)
|
|
A(3,3)=A(3,3)+CMAP(KK,2)**2*wt(n)
|
|
R(1)=R(1)+VAL(KK)*wt(n)
|
|
R(2)=R(2)+CMAP(KK,1)*VAL(KK)*wt(n)
|
|
R(3)=R(3)+CMAP(KK,2)*VAL(KK)*wt(n)
|
|
!ipk feb97 end addition of weighting
|
|
200 END DO
|
|
! read(*,*) al
|
|
!
|
|
! Solve equations
|
|
!
|
|
ATR=A(1,2)/A(1,1)
|
|
ATR2=A(1,3)/A(1,1)
|
|
B(1,1)=A(2,2)-ATR*A(1,2)
|
|
B(1,2)=A(2,3)-ATR*A(1,3)
|
|
S(1)=R(2)-ATR*R(1)
|
|
B(2,2)=A(3,3)-ATR2*A(1,3)
|
|
S(2)=R(3)-ATR2*R(1)
|
|
BTR=B(1,2)/B(1,1)
|
|
C=B(2,2)-BTR*B(1,2)
|
|
T=S(2)-BTR*S(1)
|
|
X3=T/C
|
|
X2=S(1)/B(1,1)-BTR*X3
|
|
X1=R(1)/A(1,1)-ATR*X2-ATR2*X3
|
|
!
|
|
! Substitute to get interpolated value
|
|
!
|
|
SOLN=X1+X2*X+X3*Y
|
|
RETURN
|
|
END
|
|
!
|
|
!ipksep97 new routine for soring map lines
|
|
!
|
|
SUBROUTINE SORTMAP(A,NKEY,N,IMAP)
|
|
!*********************************** .....SORT.....
|
|
!-
|
|
!......SORT IS A SIMPLE SHELL SORT ROUTINE
|
|
!-
|
|
! SHELL SORT
|
|
SAVE
|
|
!
|
|
!IPK JAN94 INTEGER*2 NKEY
|
|
DIMENSION A(*),NKEY(1),IMAP(*)
|
|
DATA VOID/1.E35/
|
|
IF(N.LT.2) RETURN
|
|
DO 90 J=1,N
|
|
NKEY(J)=J
|
|
IF(IMAP(J) .LT. 0) A(J)=VOID
|
|
90 END DO
|
|
ID = N
|
|
100 ID = ID / 2
|
|
110 IB = 1
|
|
120 GO TO 200
|
|
130 IB = IB + 1
|
|
IF( IB .LE. ID ) GO TO 200
|
|
IF( ID .GT. 1 ) GO TO 100
|
|
RETURN
|
|
200 I = IB
|
|
210 K = I + ID
|
|
220 IF( A(NKEY(I)) .LE. A(NKEY(K)) ) GO TO 250
|
|
NKT = NKEY(K)
|
|
NKEY(K) = NKEY(I)
|
|
J = I
|
|
230 K = J - ID
|
|
IF( K .LT. 1 ) GO TO 240
|
|
IF( A(NKT) .GT. A(NKEY(K)) ) GO TO 240
|
|
NKEY(J) = NKEY(K)
|
|
J = K
|
|
GO TO 230
|
|
240 NKEY(J) = NKT
|
|
250 I = I + ID
|
|
IF( I + ID .LE. N ) GO TO 210
|
|
GO TO 130
|
|
END
|
|
subroutine fillin(icountf)
|
|
USE BLKMAP
|
|
USE BLK1MOD
|
|
USE BLK2MOD
|
|
DIST(N,M)=(cord(n,1)-cord(m,1))**2+(cord(n,2)-cord(m,2))**2
|
|
CALL KCON(0)
|
|
MCOUNT=0
|
|
MCOUNTF=0
|
|
DO N=1,NP
|
|
IF(WD(N) .LT. -9997. .and. WD(N) .GT. -9998.5) THEN
|
|
MCOUNT=MCOUNT+1
|
|
DISTCUR=1.E20
|
|
NADJCT=0
|
|
DO K=1,NDELM(N)
|
|
J=NECON(N,K)
|
|
DO I=1,NCORN(J)
|
|
NC=NOP(J,I)
|
|
IF(NC .NE. 0 .AND. NC .NE. N) THEN
|
|
IF(WD(NC) .GT. -9997.) THEN
|
|
distance=dist(n,nc)
|
|
if(distance .lt. distcur) then
|
|
distcur=distance
|
|
nadjct=nc
|
|
endif
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
ENDDO
|
|
if(nadjct .gt. 0) then
|
|
wd(n)=wd(nadjct)
|
|
else
|
|
mcounfT=mcountf+1
|
|
ENDIF
|
|
if(mcount .eq. icountf) THEN
|
|
ICOUNTF=MCOUNTF
|
|
return
|
|
ENDIF
|
|
endif
|
|
enddo
|
|
ICOUNTF=MCOUNTF
|
|
return
|
|
end
|
|
|
|
SUBROUTINE FMESS(N1,N2)
|
|
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,IERR
|
|
! real ::
|
|
character*3 :: sub
|
|
|
|
call wdialogload(IDD_FBED)
|
|
ierr=infoerror(1)
|
|
|
|
CALL WDialogPutInteger(idf_integer1,n1)
|
|
|
|
|
|
CALL WDialogSelect(IDD_FBED)
|
|
ierr=infoerror(1)
|
|
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
|
ierr=infoerror(1)
|
|
|
|
DO
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
|
N2=1
|
|
RETURN
|
|
ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
|
N2=0
|
|
RETURN
|
|
ENDIF
|
|
ENDDO
|
|
RETURN
|
|
END
|
|
|