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.
439 lines
14 KiB
Fortran
439 lines
14 KiB
Fortran
5 years ago
|
SUBROUTINE GRELV
|
||
|
|
!
|
||
|
|
! THIS ROUTINE COMPUTES THE GRIDDED ELEVATION
|
||
|
|
!
|
||
|
|
use winteracter
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
!-
|
||
|
|
|
||
|
|
include 'd.inc'
|
||
|
|
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
INTEGER :: IERR,ISET
|
||
|
|
REAL :: ASET
|
||
|
|
DATA NXP,NYP/30,20/
|
||
|
|
DATA ITIM/0/
|
||
|
|
|
||
|
|
IF(ITIM .EQ. 0) THEN
|
||
|
|
NX=NXP+2
|
||
|
|
NY=NYP+2
|
||
|
|
ITIM=0
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
call wdialogload(IDD_GETINTP)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_GETINTP)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
100 continue
|
||
|
|
NXP=NX-2
|
||
|
|
NYP=NY-2
|
||
|
|
XGR=XGRID*TXSCAL
|
||
|
|
YGR=YGRID*TXSCAL
|
||
|
|
CALL WDialogPutINTEGER(IDF_INTEGER1,NXP)
|
||
|
|
CALL WDialogPutINTEGER(IDF_INTEGER2,NYP)
|
||
|
|
CALL WDialogPutREAL(IDF_REAL1,XGR)
|
||
|
|
CALL WDialogPutREAL(IDF_REAL2,YGR)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
do
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
|
||
|
|
|
||
|
|
CALL WDialogGetINTEGER(IDF_INTEGER1,NXP)
|
||
|
|
CALL WDialogGetINTEGER(IDF_INTEGER2,NYP)
|
||
|
|
CALL WDialogGetREAL(IDF_REAL1,XGR)
|
||
|
|
CALL WDialogGetREAL(IDF_REAL2,YGR)
|
||
|
|
GO TO 200
|
||
|
|
else
|
||
|
|
NRECC=0
|
||
|
|
endif
|
||
|
|
|
||
|
|
enddo
|
||
|
|
|
||
|
|
200 CONTINUE
|
||
|
|
NX=NXP+2
|
||
|
|
NY=NYP+2
|
||
|
|
XGRID=XGR/TXSCAL
|
||
|
|
YGRID=YGR/TXSCAL
|
||
|
|
!-
|
||
|
|
AXMAX = HSIZE
|
||
|
|
AYMAX = 7.0
|
||
|
|
if(xgrid .eq. 0.) then
|
||
|
|
XGRID = AXMAX/FLOAT(NX-3)
|
||
|
|
ELSE
|
||
|
|
NX=(AXMAX/XGRID+0.5)+3
|
||
|
|
ENDIF
|
||
|
|
IF(YGRID .EQ. 0.) THEN
|
||
|
|
YGRID = AYMAX/FLOAT(NY-3)
|
||
|
|
ELSE
|
||
|
|
NY=(AYMAX/YGRID+0.5)+3
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
IF(NX .GT. MAXGRD .OR. NY .GT. MAXGRD) THEN
|
||
|
|
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK, &
|
||
|
|
'Maximum number of interpolation points exceeded '//CHAR(13) &
|
||
|
|
//'Choose a lower resolution.', &
|
||
|
|
'Warning')
|
||
|
|
go to 100
|
||
|
|
endif
|
||
|
|
|
||
|
|
CALL LOCATE
|
||
|
|
!
|
||
|
|
CALL POINTEL
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE POINTEL
|
||
|
|
!*********************************** .....POINTS.....
|
||
|
|
!-
|
||
|
|
!......SUBROUTINE TO EVALUATE FUNCTION AT GRID POINTS
|
||
|
|
!-
|
||
|
|
!-
|
||
|
|
USE WINTERACTER
|
||
|
|
USE BLK1MOD
|
||
|
|
|
||
|
|
include 'd.inc'
|
||
|
|
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
!
|
||
|
|
REAL*8 XN,DNX,DNY
|
||
|
|
DOUBLE PRECISION XG,YG,XK,YK,XP,YP
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
! INCLUDE 'BLKV1.COM'
|
||
|
|
! INCLUDE 'BLKV2.COM'
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
!-
|
||
|
|
!ipk jul94 DIMENSION X(8),Y(8)
|
||
|
|
DIMENSION X(9),Y(9)
|
||
|
|
CHARACTER(LEN=255) :: FNAME,FNAMR
|
||
|
|
CHARACTER(LEN=256) :: FILTER
|
||
|
|
CHARACTER(LEN=3) :: SUB,SUB1
|
||
|
|
!-
|
||
|
|
DATA TOL/0.01/
|
||
|
|
!-
|
||
|
|
|
||
|
|
!-
|
||
|
|
!......LOOP ON ALL GRID POINTS
|
||
|
|
!-
|
||
|
|
FILTER = 'Map file *.map|*.map|'
|
||
|
|
CALL WSelectFile(FILTER,SaveDialog+PromptOn,FNAME,'Save Map File')
|
||
|
|
|
||
|
|
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||
|
|
|
||
|
|
CALL IlowerCase(FNAME)
|
||
|
|
CALL GETSUB(FNAME,SUB)
|
||
|
|
OPEN(199,FILE=FNAME,STATUS='UNKNOWN')
|
||
|
|
WRITE(199,8000)
|
||
|
|
8000 FORMAT('2,0.')
|
||
|
|
ELSE
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
DO 1000 NN=1,NX
|
||
|
|
DO 950 MM=1,NY
|
||
|
|
N=IGRID(NN,MM)
|
||
|
|
IF(N.EQ.0) GO TO 950
|
||
|
|
HGN=0.
|
||
|
|
250 CONTINUE
|
||
|
|
!-
|
||
|
|
!......DETERMINE ELEMENT TYPE
|
||
|
|
!-
|
||
|
|
!IPKOCT93 ADD
|
||
|
|
NCN=8
|
||
|
|
IT=1
|
||
|
|
|
||
|
|
IF(NOP(N,7).NE.0) GO TO 275
|
||
|
|
NCN=6
|
||
|
|
IT=2
|
||
|
|
275 CONTINUE
|
||
|
|
!-
|
||
|
|
!......ESTABLISH LOCAL COORDINATES FOR EACH NODE POINT
|
||
|
|
!-
|
||
|
|
K1=NOP(N,1)
|
||
|
|
X(1)=0.
|
||
|
|
Y(1)=0.
|
||
|
|
DO 300 K=2,NCN
|
||
|
|
K2=NOP(N,K)
|
||
|
|
X(K)=CORD(K2,1)-CORD(K1,1)
|
||
|
|
Y(K)=CORD(K2,2)-CORD(K1,2)
|
||
|
|
300 END DO
|
||
|
|
!-
|
||
|
|
!......ESTABLISH LOCAL COORDINATES OF DESIRED POINT
|
||
|
|
!-
|
||
|
|
XP=FLOAT(NN-2)*XGRID
|
||
|
|
XRL=XP*TXSCAL-XS
|
||
|
|
XP=XP-CORD(K1,1)
|
||
|
|
YP=FLOAT(MM-2)*YGRID
|
||
|
|
YRL=YP*TXSCAL-YS
|
||
|
|
YP=YP-CORD(K1,2)
|
||
|
|
XG=0.
|
||
|
|
YG=0.
|
||
|
|
!-
|
||
|
|
!......ITERATE TO FIND LOCAL COORDINATE
|
||
|
|
!-
|
||
|
|
DO 400 ITER=1,10
|
||
|
|
DXKDX=0.
|
||
|
|
DXKDY=0.
|
||
|
|
DYKDX=0.
|
||
|
|
DYKDY=0.
|
||
|
|
XK=-XP
|
||
|
|
YK=-YP
|
||
|
|
DO 350 K=2,NCN
|
||
|
|
XK=XK+XN(IT,K,XG,YG)*X(K)
|
||
|
|
YK=YK+XN(IT,K,XG,YG)*Y(K)
|
||
|
|
DXKDX=DXKDX+DNX(IT,K,XG,YG)*X(K)
|
||
|
|
DYKDX=DYKDX+DNX(IT,K,XG,YG)*Y(K)
|
||
|
|
DXKDY=DXKDY+DNY(IT,K,XG,YG)*X(K)
|
||
|
|
DYKDY=DYKDY+DNY(IT,K,XG,YG)*Y(K)
|
||
|
|
350 END DO
|
||
|
|
DET=DXKDX*DYKDY-DXKDY*DYKDX
|
||
|
|
DX=(-DYKDY*XK+DXKDY*YK)/DET
|
||
|
|
DY=( DYKDX*XK-DXKDX*YK)/DET
|
||
|
|
XG=XG+DX
|
||
|
|
YG=YG+DY
|
||
|
|
IF(ABS(DX).LT.TOL .AND. ABS(DY).LT.TOL) GO TO 420
|
||
|
|
400 END DO
|
||
|
|
!-
|
||
|
|
!......NOW EVALUATE GRID POINT
|
||
|
|
!-
|
||
|
|
420 CONTINUE
|
||
|
|
DO 450 K=1,NCN
|
||
|
|
J=NOP(N,K)
|
||
|
|
HGN=HGN+XN(IT,K,XG,YG)*WD(J)
|
||
|
|
450 END DO
|
||
|
|
WRITE(199,9800) XRL,YRL,HGN
|
||
|
|
9800 FORMAT(F14.2',',F14.2,',',F14.3)
|
||
|
|
950 END DO
|
||
|
|
1000 END DO
|
||
|
|
! IF(NVEL .EQ. 1) WRITE(6,9803) ((UGRID(NN,MM),MM=1,32),
|
||
|
|
! 1NN=1,32)
|
||
|
|
! IF(NVEL .EQ. 1) WRITE(6,9803) ((VGRID(NN,MM),MM=1,32),
|
||
|
|
! 1NN=1,32)
|
||
|
|
9803 FORMAT(8E12.4)
|
||
|
|
! WRITE(6,9802)((GRID(NN,MM),MM=1,16),NN=1,16)
|
||
|
|
!9802 FORMAT(16F8.2)
|
||
|
|
WRITE(199,8001)
|
||
|
|
8001 FORMAT('END')
|
||
|
|
WRITE(199,8001)
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
!
|
||
|
|
SUBROUTINE LOCATE
|
||
|
|
!*********************************** .....LOCATE.....
|
||
|
|
!-
|
||
|
|
!......LOCATE ESTABLISHES ELEMENT NUMBERS FOR ALL GRID POINTS
|
||
|
|
!-
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
! INCLUDE 'BLKV1.COM'
|
||
|
|
! INCLUDE 'BLKV2.COM'
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
!
|
||
|
|
COMMON XS(4,3),YS(4,3),XM(4,3),ROOT(10)
|
||
|
|
!
|
||
|
|
VOID=1.E+20
|
||
|
|
NPTS= 7
|
||
|
|
DS=1./(FLOAT(NPTS)-1.)
|
||
|
|
DO 340 N=1,MAXGRD
|
||
|
|
DO 340 M=1,MAXGRD
|
||
|
|
340 IGRID(N,M)=0
|
||
|
|
!-
|
||
|
|
!....... PROCESS EACH ELEMENT
|
||
|
|
!-
|
||
|
|
DO 900 N=1,NE
|
||
|
|
IF(IESKP(N) .NE. 0) GO TO 900
|
||
|
|
IF(IMAT(N).LE.0) GO TO 900
|
||
|
|
IF(NOP(N,6) .EQ. 0) GO TO 900
|
||
|
|
XMINN=VOID
|
||
|
|
YMINN=VOID
|
||
|
|
XMAXX=-VOID
|
||
|
|
YMAXX=-VOID
|
||
|
|
!-
|
||
|
|
!...... TRACE AROUND EACH SIDE FOR MAX AND MIN LOCATIONS
|
||
|
|
!-
|
||
|
|
NCN=8
|
||
|
|
IF(NOP(N,7).EQ.0) NCN=6
|
||
|
|
NSIDE=NCN/2
|
||
|
|
K=0
|
||
|
|
DO 600 M=1,NCN,2
|
||
|
|
K=K+1
|
||
|
|
M1=NOP(N,M)
|
||
|
|
M2=NOP(N,M+1)
|
||
|
|
M3=MOD(M+2,NCN)
|
||
|
|
M3=NOP(N,M3)
|
||
|
|
XS(K,1)=CORD(M1,1)
|
||
|
|
XS(K,2)=CORD(M2,1)
|
||
|
|
XS(K,3)=CORD(M3,1)
|
||
|
|
YS(K,1)=CORD(M1,2)
|
||
|
|
YS(K,2)=CORD(M2,2)
|
||
|
|
YS(K,3)=CORD(M3,2)
|
||
|
|
XM(K,1)=2.*XS(K,1)-4.*XS(K,2)+2.*XS(K,3)
|
||
|
|
XM(K,2)=-3.*XS(K,1)+4.*XS(K,2)-XS(K,3)
|
||
|
|
XM(K,3)=XS(K,1)
|
||
|
|
!-
|
||
|
|
!..... WORK ALONG BOUNDARY OF ELEMENT
|
||
|
|
!-
|
||
|
|
S=0.
|
||
|
|
DO 550 J=1,NPTS
|
||
|
|
XN1=(1.-S)*(1.-2.*S)
|
||
|
|
XN2=4.*(1.-S)*S
|
||
|
|
XN3=S*(2.*S-1.)
|
||
|
|
X=XN1*XS(K,1)+XN2*XS(K,2)+XN3*XS(K,3)
|
||
|
|
Y=XN1*YS(K,1)+XN2*YS(K,2)+XN3*YS(K,3)
|
||
|
|
IF(X.LT.XMINN) XMINN=X
|
||
|
|
IF(X.GT.XMAXX) XMAXX=X
|
||
|
|
IF(Y.LT.YMINN) YMINN=Y
|
||
|
|
IF(Y.GT.YMAXX) YMAXX=Y
|
||
|
|
S=S+DS
|
||
|
|
550 END DO
|
||
|
|
600 END DO
|
||
|
|
!-
|
||
|
|
!...... ESTABLISH GRID FRAMEWORK
|
||
|
|
!-
|
||
|
|
XLH=XMINN/XGRID
|
||
|
|
XRH=XMAXX/XGRID
|
||
|
|
YBT=YMINN/YGRID
|
||
|
|
YTP=YMAXX/YGRID
|
||
|
|
IXL=XLH+2.999
|
||
|
|
IXT=XRH+2.001
|
||
|
|
IYL=YBT+2.999
|
||
|
|
IYT=YTP+2.001
|
||
|
|
IERR=0
|
||
|
|
!$$$
|
||
|
|
IF(IXL.LT.0) IERR=1
|
||
|
|
IF (IXL .LT. 1) IXL = 1
|
||
|
|
IF(IYL.LT.0) IERR=1
|
||
|
|
IF (IYL .LT. 1) IYL = 1
|
||
|
|
IF(IXT.GT.NX) IERR=1
|
||
|
|
IF (IXT .GT. NX) IXT = NX
|
||
|
|
IF(IYT.GT.NY) IERR=1
|
||
|
|
IF (IYT .GT. NY) IYT = NY
|
||
|
|
!
|
||
|
|
IF(IERR.EQ.0) GO TO 620
|
||
|
|
! WRITE(6,9989) N
|
||
|
|
! 9989 FORMAT(///' ERROR STOP FOR ELEMENT',I5)
|
||
|
|
! WRITE(6,9990) (K,(XS(K,M),YS(K,M),XM(K,M),M=1,3),K=1,NSIDE)
|
||
|
|
! 9990 FORMAT(I10,9E13.4)
|
||
|
|
! WRITE(6,9992) XLH,XRH,YBT,YTP,IXL,IXT,IYL,IYT
|
||
|
|
! 9992 FORMAT(4F20.6,4I8)
|
||
|
|
!$$$ STOP
|
||
|
|
620 CONTINUE
|
||
|
|
!-
|
||
|
|
!...... FIND INTERSECTIONS FOR HORIZONTAL GRID LINE
|
||
|
|
!-
|
||
|
|
DO 800 M=IYL,IYT
|
||
|
|
Y=(M-2)*YGRID
|
||
|
|
IL=0
|
||
|
|
DO 700 K=1,NSIDE
|
||
|
|
A=2.*YS(K,1)-4.*YS(K,2)+2.*YS(K,3)
|
||
|
|
B=-3.*YS(K,1)+4.*YS(K,2)-YS(K,3)
|
||
|
|
C=YS(K,1)-Y
|
||
|
|
SQ=B**2-4.*A*C
|
||
|
|
IF(ABS(A).LT.0.01) GO TO 650
|
||
|
|
IF(SQ.GT..001) GO TO 660
|
||
|
|
IF(SQ.LT.-.001) GO TO 700
|
||
|
|
S=-B/(2.*A)
|
||
|
|
IF(S.LT.0. .OR. S.GT.1.0) GO TO 700
|
||
|
|
IL=IL+1
|
||
|
|
ROOT(IL)=XM(K,1)*S**2+XM(K,2)*S+XM(K,3)
|
||
|
|
IL=IL+1
|
||
|
|
ROOT(IL)=ROOT(IL-1)
|
||
|
|
GO TO 700
|
||
|
|
650 IF(ABS(B).LT. 0.001) GO TO 700
|
||
|
|
S=-C/B
|
||
|
|
GO TO 670
|
||
|
|
660 CONTINUE
|
||
|
|
S=(-B+SQRT(SQ))/(2.*A)
|
||
|
|
IF(S.LT.0. .OR. S.GT.1.0) GO TO 665
|
||
|
|
IL=IL+1
|
||
|
|
ROOT(IL)=XM(K,1)*S**2+XM(K,2)*S+XM(K,3)
|
||
|
|
665 S=(-B-SQRT(SQ))/(2.*A)
|
||
|
|
670 CONTINUE
|
||
|
|
IF(S.LT.0. .OR. S.GT.1.0) GO TO 700
|
||
|
|
IL=IL+1
|
||
|
|
ROOT(IL)=XM(K,1)*S**2+XM(K,2)*S+XM(K,3)
|
||
|
|
700 END DO
|
||
|
|
IF(IL.GT.0) GO TO 705
|
||
|
|
DO 703 K=1,NSIDE
|
||
|
|
IF(ABS(YS(K,3)-Y).LT.0.05) GO TO 704
|
||
|
|
703 END DO
|
||
|
|
GO TO 800
|
||
|
|
704 IL=2
|
||
|
|
ROOT(1)=XS(K,3)-0.05
|
||
|
|
ROOT(2)=XS(K,3)+0.05
|
||
|
|
705 CONTINUE
|
||
|
|
CALL SORTE(ROOT,IL)
|
||
|
|
! ISET=0
|
||
|
|
IC=1
|
||
|
|
!-
|
||
|
|
!....... LOCATE VALUES INTO IGRID
|
||
|
|
!-
|
||
|
|
9908 FORMAT(I10,F20.2)
|
||
|
|
9997 FORMAT(5F20.4)
|
||
|
|
DO 750 K=IXL,IXT
|
||
|
|
X=(K-2)*XGRID
|
||
|
|
710 CONTINUE
|
||
|
|
IF(X.LE.ROOT(IC)) GO TO 720
|
||
|
|
IC=IC+1
|
||
|
|
IF(IC.GT.IL) GO TO 800
|
||
|
|
GO TO 710
|
||
|
|
720 IF(MOD(IC,2).EQ.0) IGRID(K,M)=N
|
||
|
|
750 END DO
|
||
|
|
800 END DO
|
||
|
|
900 END DO
|
||
|
|
!CC WRITE(*,9800) ((IGRID(N,M),N=1,20),M=1,20)
|
||
|
|
9800 FORMAT(20I3)
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
!
|
||
|
|
SUBROUTINE SORTE(A,N)
|
||
|
|
!*********************************** .....SORT.....
|
||
|
|
!-
|
||
|
|
!......SORT IS A SIMPLE SHELL SORT ROUTINE
|
||
|
|
!-
|
||
|
|
! SHELL SORT
|
||
|
|
SAVE
|
||
|
|
!
|
||
|
|
DIMENSION A(*)
|
||
|
|
IF(N.LT.2) RETURN
|
||
|
|
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(I) .LE. A(K) ) GO TO 250
|
||
|
|
T = A(K)
|
||
|
|
A(K) = A(I)
|
||
|
|
J = I
|
||
|
|
230 K = J - ID
|
||
|
|
IF( K .LT. 1 ) GO TO 240
|
||
|
|
IF( T .GT. A(K) ) GO TO 240
|
||
|
|
A(J) = A(K)
|
||
|
|
J = K
|
||
|
|
GO TO 230
|
||
|
|
240 A(J) = T
|
||
|
|
250 I = I + ID
|
||
|
|
IF( I + ID .LE. N ) GO TO 210
|
||
|
|
GO TO 130
|
||
|
|
END
|
||
|
|
!
|