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 !