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.
291 lines
8.0 KiB
Fortran
291 lines
8.0 KiB
Fortran
SUBROUTINE RESETWHGT
|
|
USE BLK1MOD
|
|
USE BLK2MOD
|
|
INCLUDE 'TXFRM.COM'
|
|
SAVE
|
|
DIST(N,M)=Sqrt((cord(n,1)-cord(m,1))**2+(cord(n,2)-cord(m,2))**2)*txscal
|
|
! INCLUDE 'BLK1A.COM'
|
|
! DIMENSION K1(50000),levrem(50000)
|
|
! ALLOCATABLE NRF(:),AREF(:),LEVREM(:),TRANSEL(:),WLEN(:),WHGT(:),TRCEL(:)
|
|
IF(.NOT. ALLOCATED (NRF)) THEN
|
|
ALLOCATE (NRF(MAXP),AREF(MAXP),LEVREM(MAXP))
|
|
ENDIF
|
|
IF(.NOT. ALLOCATED (TRANSEL)) THEN
|
|
ALLOCATE(TRANSEL(MAXP),WLEN(MAXP),WHGT(MAXP))
|
|
ENDIF
|
|
NRF=0
|
|
AREF=0
|
|
K1=0
|
|
levrem=0
|
|
WHGT=-9999.
|
|
call kcon(1)
|
|
CALL PANELWHT(IWTYP,ISWL,R1,R2)
|
|
IF(IWTYP .LE. 0) RETURN
|
|
IF(ISWL .EQ. 2) GO TO 300
|
|
DO N=1,NE
|
|
IF(IMAT(N) .EQ. IWTYP) THEN
|
|
DO K=2,6,4
|
|
KK=NOP(N,K)
|
|
DO M=1,NE
|
|
IF(IMAT(M) .EQ. IWTYP) CYCLE
|
|
DO L=2,NCORN(M),2
|
|
IF(NOP(M,L) .EQ. KK) THEN
|
|
IF(NCORN(M) .EQ. 8) THEN
|
|
IF(L .EQ. 2) THEN
|
|
IOP1=NOP(M,5)
|
|
IOP2=NOP(M,7)
|
|
ELSEIF(L .EQ. 4) THEN
|
|
IOP1=NOP(M,7)
|
|
IOP2=NOP(M,1)
|
|
ELSEIF(L .EQ. 6) THEN
|
|
IOP1=NOP(M,1)
|
|
IOP2=NOP(M,3)
|
|
ELSEIF(L .EQ. 8) THEN
|
|
IOP1=NOP(M,3)
|
|
IOP2=NOP(M,5)
|
|
ENDIF
|
|
|
|
ELSE
|
|
IF(L .EQ. 2) THEN
|
|
IOP1=NOP(M,5)
|
|
IOP2=NOP(M,5)
|
|
ELSEIF(L .EQ. 4) THEN
|
|
IOP1=NOP(M,1)
|
|
IOP2=NOP(M,1)
|
|
ELSE
|
|
IOP1=NOP(M,3)
|
|
IOP2=NOP(M,3)
|
|
ENDIF
|
|
ENDIF
|
|
IF(NRF(NOP(N,K-1)) .EQ. 0) THEN
|
|
NRF(NOP(N,K-1))=IOP1
|
|
AREF(NOP(N,K-1))=WD(IOP1)
|
|
ELSEIF(WD(IOP1) .GT. WD(NOP(N,K-1))) THEN
|
|
NRF(NOP(N,K-1))=IOP1
|
|
AREF(NOP(N,K-1))=WD(IOP1)
|
|
ENDIF
|
|
IF(NRF(NOP(N,K+1)) .EQ. 0) THEN
|
|
NRF(NOP(N,K+1))=IOP2
|
|
AREF(NOP(N,K+1))=WD(IOP2)
|
|
ELSEIF(WD(IOP2) .GT. WD(NOP(N,K+1))) THEN
|
|
NRF(NOP(N,K+1))=IOP2
|
|
AREF(NOP(N,K+1))=WD(IOP2)
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
ENDDO
|
|
ENDDO
|
|
ENDIF
|
|
ENDDO
|
|
DO N=1,NE
|
|
IF(IMAT(N) .EQ. IWTYP) THEN
|
|
DO K=1,7,2
|
|
IF(AREF(NOP(N,K)) .GE. WD(NOP(N,K))-0.1) THEN
|
|
IMAT(N)=IWTYP
|
|
nnn=nop(n,k)
|
|
write(151,*) 'levee reset',n,k,nnn,aref(nnn),WD(nnn)
|
|
do kk=1,7,2
|
|
levrem(nop(n,kk))=1
|
|
enddo
|
|
GO TO 150
|
|
ELSEIF(NRF(NOP(N,K)) .EQ. 0) THEN
|
|
IMAT(N)=99
|
|
nnn=nop(n,k)
|
|
write(151,*) 'Levee element removed',n,k,nnn
|
|
GO TO 150
|
|
ELSE
|
|
WRITE(151,*) 'Levee active', n,aref(nop(n,k)),iop1
|
|
IMAT(N)=IWTYP+900
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
150 CONTINUE
|
|
ENDDO
|
|
IF(IWTP .LT. 900) IWTYP=IWTYP+900
|
|
DO N=1,NE
|
|
IF(IMAT(N) .EQ. IWTYP) THEN
|
|
KCT=1
|
|
NPK1=NOP(N,1)
|
|
NPK2=NOP(N,3)
|
|
160 CONTINUE
|
|
IF(levrem(NPK1) .eq. 1) then
|
|
if(levrem(npk2) .eq. 1) then
|
|
IMAT(N)=IWTYP-900
|
|
GO TO 180
|
|
else
|
|
IF(KCT .EQ. 1) THEN
|
|
MA=NECON(NOP(N,4),1)
|
|
MB=NECON(NOP(N,4),2)
|
|
ELSE
|
|
MA=NECON(NOP(N,8),1)
|
|
MB=NECON(NOP(N,8),2)
|
|
ENDIF
|
|
IF(MA .EQ. N) MA=MB
|
|
IF(MA .NE. 0) THEN
|
|
IF(NOP(MA,1) .EQ. NPK2) THEN
|
|
IF(LEVREM(NOP(MA,3)) .EQ. 1) THEN
|
|
IMAT(N)=IWTYP-900
|
|
IMAT(MA)=IWTYP-900
|
|
ENDIF
|
|
ELSEIF(NOP(MA,3) .EQ. NPK2) THEN
|
|
IF(LEVREM(NOP(MA,1)) .EQ. 1) THEN
|
|
IMAT(N)=IWTYP-900
|
|
IMAT(MA)=IWTYP-900
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
endif
|
|
ENDIF
|
|
NPK2=NOP(N,1)
|
|
NPK1=NOP(N,3)
|
|
IF(KCT .EQ. 1) THEN
|
|
KCT=2
|
|
GO TO 160
|
|
ENDIF
|
|
ENDIF
|
|
180 CONTINUE
|
|
ENDDO
|
|
DO N=1,NE
|
|
IF(IMAT(N) .EQ. IWTYP) THEN
|
|
DO K=1,7,2
|
|
IOP1=NRF(NOP(N,K))
|
|
IF(IOP1 .GT. 0) THEN
|
|
NPK=NOP(N,K)
|
|
WHGT(NPK)=WD(NPK)
|
|
TRANSEL(NPK)=WHGT(NPK)+R1
|
|
n1=nop(n,k)
|
|
n2=nop(n,8-k)
|
|
wlen(NPK)=dist(n1,n2)
|
|
NRF(NPK)=-NRF(NPK)
|
|
if(levrem(NPK) .eq. 0) then
|
|
WD(NPK)=WD(IOP1)
|
|
TRANSEL(NPK)=WHGT(NPK)+R1
|
|
n1=nop(n,k)
|
|
n2=nop(n,8-k)
|
|
wlen(NPK)=dist(n1,n2)
|
|
! wlen(NPK)=8.
|
|
endif
|
|
ENDIF
|
|
ENDDO
|
|
200 CONTINUE
|
|
! AMMN=(WHGT(NOP(N,1))+WHGT(NOP(N,3)))/2.
|
|
! IF(AMMN .GT. WHGT(NOP(N,1))) THEN
|
|
! TRCEL(N)=AMMN - WHGT(NOP(N,1))+0.1
|
|
! ELSE
|
|
! TRCEL(N)=AMMN - WHGT(NOP(N,3))+0.1
|
|
! ENDIF
|
|
! TRCEL(N)=0.25
|
|
! write(151,*) 'levee element trc set',n,trcel(n),whgt(nop(n,1))&
|
|
! ,whgt(nop(n,3))
|
|
ENDIF
|
|
ENDDO
|
|
DEALLOCATE (NRF,AREF,LEVREM)
|
|
GO TO 400
|
|
300 CONTINUE
|
|
DO N=1,NE
|
|
IF(IMAT(N) .EQ. IWTYP) THEN
|
|
DO K=1,7,2
|
|
NPK=NOP(N,K)
|
|
WHGT(NPK)=WD(NPK)+R2
|
|
TRANSEL(NPK)=WHGT(NPK)+R1
|
|
n1=nop(n,k)
|
|
n2=nop(n,8-k)
|
|
wlen(NPK)=dist(n1,n2)
|
|
ENDDO
|
|
ENDIF
|
|
ENDDO
|
|
400 call OUTWDT
|
|
RETURN
|
|
END
|
|
|
|
SUBROUTINE PANELWHT(N1,ISWL,R1,R2)
|
|
|
|
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,IERR,ISWL
|
|
real :: R1,R2
|
|
character*3 :: sub
|
|
|
|
call wdialogload(IDD_SETWRS)
|
|
ierr=infoerror(1)
|
|
|
|
call wdialogputRadioButton(idf_radio1)
|
|
CALL WDialogPutInteger(idf_integer1,n1)
|
|
CALL WDialogPutReal(idf_real1,r1)
|
|
CALL WDialogPutReal(idf_real2,r2)
|
|
|
|
|
|
CALL WDialogSelect(IDD_SETWRS)
|
|
ierr=infoerror(1)
|
|
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
|
ierr=infoerror(1)
|
|
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
|
call wdialoggetradiobutton(idf_radio1,ISWL)
|
|
CALL WDialogGetInteger(idf_integer1,n1)
|
|
CALL WDialogGetReal(idf_real1,r1)
|
|
CALL WDialogGetReal(idf_real2,r2)
|
|
ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
|
N1=-1
|
|
|
|
ENDIF
|
|
RETURN
|
|
END
|
|
|
|
SUBROUTINE OUTWDT
|
|
|
|
USE WINTERACTER
|
|
USE BLK1MOD
|
|
INCLUDE 'TXFRM.COM'
|
|
|
|
CHARACTER(LEN=255) :: FNAME,FILTER
|
|
CHARACTER(LEN=4) :: SUB
|
|
LOGICAL OPENED
|
|
CHARACTER*1 IFLAG,ANS(10)
|
|
|
|
IOUTWR=81
|
|
INQUIRE(81, OPENED=OPENED)
|
|
if(.not. opened) then
|
|
Filter='WDT file -- *.dat|*.dat|'
|
|
|
|
CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Weir Data File')
|
|
|
|
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
|
|
|
CALL IlowerCase(FNAME)
|
|
CALL GETSUB(FNAME,SUB)
|
|
OPEN(IOUTWR,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE')
|
|
GO TO 3
|
|
ELSE
|
|
GO TO 1
|
|
ENDIF
|
|
ELSE
|
|
REWIND(IOUTWR)
|
|
GO TO 3
|
|
ENDIF
|
|
|
|
1 RETURN
|
|
|
|
3 DO N=1,NP
|
|
IF(WHGT(N) .GT. -9999.) THEN
|
|
WRITE(IOUTWR,7778) N,WHGT(N),WLEN(N),TRANSEL(N)
|
|
7778 FORMAT('WDT',5X,I8,3F8.2)
|
|
ENDIF
|
|
ENDDO
|
|
CLOSE(IOUTWR)
|
|
|
|
RETURN
|
|
END |