iank
/
RMAGEN84
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
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.
master
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '601f33fc45'
${ noResults }
RMAGEN84/SRC84/INTEL.F90

439 lines
14 KiB
Fortran
Raw Blame History

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
!
Reference in New Issue View Git Blame Copy Permalink