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/AREA.F90

463 lines
14 KiB
Fortran
Raw Normal View History Unescape Escape

VERSION84 WITH NEW GRID PLOTTING AND 1D EXPANSION
5 years ago
!IPK LAST UPDATE JULY 7 2016 ADD TEST FOR ZERO WIDTH
SUBROUTINE CHKAREA
USE WINTERACTER
USE BLK1MOD
include 'd.inc'
! INCLUDE 'BLK1.COM'
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
dimension itran(0:16)
data itran/0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/
DATA I1,I2,I3,I4/1,0,0,0/,EMAX/-1./
WRITE(90,*) 'GOING TO CHKOPT'
CALL GETCHOPT(I1,I2,I3,I4,EREF,WIDEL)
WRITE(90,*) I1
IF(I1 .LT. 0) THEN
I1=1
I2=0
RETURN
ENDIF
IF(I1 .EQ. 1) THEN
! and see if all corner nodes exist
!
! Test for areas of each element
!
INEG = 0
!IPK JUL16
IERW=0
DO 250 N=1,NE
IF(IMAT(N) .GT. 0 .AND. NCORN(N) .GT. 5) THEN
J1=NOP(N,1)
J2=NOP(N,3)
J3=NOP(N,5)
if(cord(j1,1) .lt. -1.e9 .or. cord(j2,1) .lt. -1.e9 .or. cord(j3,1) .lt. -1.e9) then
WRITE(90,*) ' NODE UNDEFINED FOR ELEMENT NUMBER',N
CALL DELTEL(N)
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Element removed','ELEMENT REMOVED')
GO TO 250
ENDIF
AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- &
& (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2))
IF(AREA .LT. 0.) THEN
WRITE(90,*) ' NEGATIVE AREA FOR ELEMENT NUMBER',N
INEG = 1
GO TO 250
ENDIF
IF(NCORN(N) .EQ. 8) THEN
J1=NOP(N,3)
J2=NOP(N,5)
J3=NOP(N,7)
if(cord(j1,1) .lt. -1.e9 .or. cord(j2,1) .lt. -1.e9 .or. cord(j3,1) .lt. -1.e9) then
WRITE(90,*) ' NODE UNDEFINED FOR ELEMENT NUMBER',N
CALL DELTEL(N)
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Element removed','ELEMENT REMOVED')
GO TO 250
ENDIF
AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- &
& (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2))
IF(AREA .LT. 0.) THEN
WRITE(90,*) ' NEGATIVE AREA FOR ELEMENT NUMBER',N
INEG = 1
ENDIF
ENDIF
!IPK JUL16 ADD TEST FOR MISSING WIDTH
ELSEIF(IMAT(N) .GT. 0) THEN
IF(WIDTH(NOP(N,1)) .EQ. 0. .OR. WIDTH(NOP(N,3)) .EQ. 0) THEN
IF(IERW .EQ. 0) THEN
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Nodal width missing in 1-D element'//Char(13)//&
'See file MESSGEN.OUT for details' ,'WARNING 1-D WIDTH MISSING')
write(90,6000)
write(90,6001) n,nop(n,1),width(nop(n,1)),nop(n,3),width(nop(n,3))
6000 FORMAT(' NODAL WIDTH MISSING FOR 1-D ELEMENT'/' ELEMENT NODE1 WIDTH1 NODE2 WIDTH2')
6001 FORMAT(I8,2(I10,F10.2))
IERW=1
ELSE
write(90,6001) n,nop(n,1),width(nop(n,1)),nop(n,3),width(nop(n,3))
ENDIF
ENDIF
ENDIF
250 END DO
IF(INEG .EQ. 1) THEN
!cipk aug00
Call WMessageBox(3,2,1,'Negative Areas have been found'//Char(13)//&
'See file MESSGEN.OUT for details'//'Press YES to set positive',&
'ERROR IN NETWORK AREAS!!')
IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then
!
! Test for areas of each element
!
INEG=0
DO 300 N=1,NE
IF(IMAT(N) .GT. 0 .AND. NCORN(N) .GT. 5) THEN
J1=NOP(N,1)
J2=NOP(N,3)
J3=NOP(N,5)
AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- &
& (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2))
IF(AREA .LT. 0.) THEN
if(NCORN(N) .EQ. 6) THEN
JM12=NOP(N,2)
JM23=NOP(N,4)
JM31=NOP(N,6)
NOP(N,2)=JM31
NOP(N,3)=J3
NOP(N,4)=JM23
NOP(N,5)=J2
NOP(N,6)=JM12
GO TO 300
ELSEIF(NCORN(N) .EQ. 8) THEN
INEG=1
ENDIF
ENDIF
IF(NCORN(N) .EQ. 8) THEN
J1=NOP(N,3)
J2=NOP(N,5)
J3=NOP(N,7)
AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- &
& (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2))
IF(AREA .LT. 0.) THEN
IF(INEG .EQ. 1) THEN
J0=NOP(N,1)
JM01=NOP(N,2)
JM12=NOP(N,4)
JM23=NOP(N,6)
JM30=NOP(N,8)
NOP(N,2)=JM30
NOP(N,3)=J3
NOP(N,4)=JM23
NOP(N,5)=J2
NOP(N,6)=JM12
NOP(N,7)=J1
NOP(N,8)=JM01
ELSE
WRITE(90,*) ' CROSS OVER NEGATIVE AREA FOR ELEMENT NUMBER',N
Call WMessageBox(3,2,1,'cross-over element diagonals have been found'//Char(13)//&
'See file MESSGEN.OUT for details'//'Press YES to set delete',&
'ERROR IN NETWORK AREAS!!')
IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then
CALL DELTEL(N)
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
300 END DO
ENDIF
ENDIF
ENDIF
! CARRY OUT TEST FOR ELEMENT ELEVATION DIFFERENCES
IF(I2 .EQ. 1) THEN
EMAX=0.
DO N=1,NE
EDIF(N)=0
IF(IMAT(N) .LE. 0) GO TO 400
IF(NCORN(N) .GT. 5) THEN
DO M=1,NCORN(N)-1,2
DO MM=M,NCORN(N)-1,2
EDIF(N)=MAX(ABS(WD(NOP(N,M))-WD(NOP(N,MM))),EDIF(N))
ENDDO
ENDDO
ELSE
IF(I4 .EQ. 0) THEN
EDIF(N)=ABS(WD(NOP(N,3))-WD(NOP(N,1)))
ELSE
if(icrin .eq. 0) then
CALL WMessageBox(0, 4, 1,'Cross-section data not loaded '//CHAR(13)// &
'Click OK start again','ERROR GETTING NO SECTION DATA')
RETURN
endif
N1=NOP(N,1)
N2=NOP(N,3)
BT1= &
CRSDAT(NRIVCR1(N1),1,1)*WTRIVCR1(N1)+ &
CRSDAT(NRIVCR2(N1),1,1)*WTRIVCR2(N1)
BT2= &
CRSDAT(NRIVCR1(N2),1,1)*WTRIVCR1(N2)+ &
CRSDAT(NRIVCR2(N2),1,1)*WTRIVCR2(N2)
H1=WIDEL-BT1
H2=WIDEL-BT2
IF(H1 .LT. 0. .OR. H2 .LT. 0.) THEN
CALL WMessageBox(1, 4, 1,'Depth negative '//CHAR(13)// &
'Click OK to continue with depth=1.'//CHAR(13)//'Click Cancel to start again','ERROR GETTING SECTION DATA')
if(WInfoDialog(4) .eq. 0) then
RETURN
else
IF(H1 .LT. 0.) H1=1.0
IF(H2 .LT. 0.) H2=1.0
endif
ENDIF
CALL INTERPWLV(N1,H1,AR1,WR1,DWR1)
CALL INTERPWLV(N2,H2,AR2,WR2,DWR2)
IF(I4 .EQ. 1) THEN
EDIF(N)=ABS(WR1-WR2)
ELSE
EDIF(N)=ABS(AR1-AR2)
ENDIF
ENDIF
ENDIF
IF(EDIF(N) .GT. EMAX) EMAX=EDIF(N)
400 CONTINUE
ENDDO
NUMV=13
CONTUR(1)=-0.5
DO K=2,13
CONTUR(K)=(EMAX+0.5)/12.+CONTUR(K-1)
ENDDO
DO N=1,NE
! IF(N .EQ. 46451) WRITE(155,*) N,EMAX,EDIF(N)
IF(IMAT(N) .GT. 0) THEN
IF(EDIF(N) .LT. 0.001) THEN
ICOL=1
ELSE
ICOL=EDIF(N)*12./EMAX+.999
ENDIF
icll=itran(icol)
! IF(N .EQ. 46451) WRITE(155,*) N,ICOL,EMAX,EDIF(N)
CALL FILLEMC(N,ICLL)
ENDIF
ENDDO
XLEG=8.8
YLEG=7.4
CALL LEGND(XLEG,YLEG,CONTUR,NUMV,NUMCOL)
ENDIF
EDIF(0)=EMAX
CALL WMenuSetState(ID_SECGRP,ItemEnabled,1)
IF(I2 .EQ. 1) RETURN
! CARRY OUT TEST FOR ELEMENT NORMAILZED DEPTH DIFFERENCES
IF(I3 .EQ. 1) THEN
EMAX=0.
DO N=1,NE
EDIF(N)=0
IF(IMAT(N) .LE. 0) GO TO 500
IF(NCORN(N) .GT. 5) THEN
DO M=1,NCORN(N)-1,2
DO MM=M,NCORN(N)-1,2
D1=EREF-WD(NOP(N,M))
D2=EREF-WD(NOP(N,MM))
if(d1 .lt. 0.0) d1=0.0
if(d2 .lt. 0.0) d2=0.0
DMEAN=(D1+D2)/2.
if(DMEAN .LE. 1.) DMEAN=1.0
EDIF(N)=MAX(ABS(D1-D2)/DMEAN,EDIF(N))
ENDDO
ENDDO
ELSE
IF(I4 .EQ. 0) THEN
D1=EREF-WD(NOP(N,1))
D2=EREF-WD(NOP(N,3))
IF(D1 .LT. 0. .OR. D2 .LT. 0.) THEN
CALL WMessageBox(1, 4, 1,'Depth negative '//CHAR(13)// &
'Click OK to continue with depth=1.'//CHAR(13)//'Click Cancel to start again','ERROR GETTING SECTION DATA')
if(WInfoDialog(4) .eq. 0) then
RETURN
else
IF(D1 .LT. 0.) D1=1.0
IF(D2 .LT. 0.) D2=1.0
endif
ENDIF
DMEAN=(D1+D2)/2.
if(DMEAN .LE. 1.) DMEAN=1.0
EDIF(N)=ABS(D1-D2)/DMEAN
ELSE
if(icrin .eq. 0) then
CALL WMessageBox(0, 4, 1,'Cross-section data not loaded '//CHAR(13)// &
'Click OK start again','ERROR GETTING NO SECTION DATA')
RETURN
endif
N1=NOP(N,1)
N2=NOP(N,3)
BT1= &
CRSDAT(NRIVCR1(N1),1,1)*WTRIVCR1(N1)+ &
CRSDAT(NRIVCR2(N1),1,1)*WTRIVCR2(N1)
BT2= &
CRSDAT(NRIVCR1(N2),1,1)*WTRIVCR1(N2)+ &
CRSDAT(NRIVCR2(N2),1,1)*WTRIVCR2(N2)
H1=WIDEL-BT1
H2=WIDEL-BT2
IF(H1 .LT. 0. .OR. H2 .LT. 0.) THEN
CALL WMessageBox(1, 4, 1,'Depth negative '//CHAR(13)// &
'Click OK to continue with depth=1.'//CHAR(13)//'Click Cancel to start again','ERROR GETTING SECTION DATA')
if(WInfoDialog(4) .eq. 0) then
RETURN
else
IF(H1 .LT. 0.) H1=1.0
IF(H2 .LT. 0.) H2=1.0
endif
ENDIF
CALL INTERPWLV(N1,H1,AR1,WR1,DWR1)
CALL INTERPWLV(N2,H2,AR2,WR2,DWR2)
IF(I4 .EQ. 1) THEN
EDIF(N)=ABS(WR1-WR2)*2./(WR1+WR2)
ELSE
EDIF(N)=ABS(AR1-AR2)*2./(AR1+AR2)
ENDIF
ENDIF
ENDIF
IF(EDIF(N) .GT. EMAX) EMAX=EDIF(N)
500 CONTINUE
ENDDO
NUMV=11
CONTUR(1)=0.
DO K=2,11
CONTUR(K)=EMAX/10.+CONTUR(K-1)
ENDDO
DO N=1,NE
IF(IMAT(N) .GT. 0) THEN
ICOL=EDIF(N)*10./EMAX+.999
icll=itran(icol)
CALL FILLEMC(N,ICLL)
ENDIF
ENDDO
XLEG=8.8
YLEG=7.4
CALL LEGND(XLEG,YLEG,CONTUR,NUMV,NUMCOL)
ENDIF
EDIF(0)=EMAX
CALL WMenuSetState(ID_SECGRP,ItemEnabled,1)
FLUSH(90)
IF(I3 .EQ. 1) RETURN
CALL PLOTOT(0)
CALL HEDR
RETURN
END
SUBROUTINE GETCHOPT(I1,I2,I3,I4,EREF,WIDEL)
!
! Generate continuity lines
!
USE WINTERACTER
include 'd.inc'
SAVE
!
! Declare window-type and message variables
!
TYPE(WIN_STYLE) :: WINDOW
TYPE(WIN_MESSAGE) :: MESSAGE
integer :: I1,I2,I3,I4,I4A,ITIME,IPOS
REAL :: WIDEL
REAL :: EREF
data itime/0/
IF(ITIME .EQ. 0) THEN
EREF=0.
WIDEL=0.
itime=1.
I4=0
ENDIF
call wdialogload(IDD_CHKOPT)
ierr=infoerror(1)
CALL WDialogSelect(IDD_CHKOPT)
ierr=infoerror(1)
I4A=I4
IF(I4 .GT. 0) I4A=1
call wdialogputCheckBox(idf_check1,I1)
call wdialogputCheckBox(idf_check2,I4A)
if(i2 .eq. 1) then
CALL WDialogPutRadioButton(IDF_RADIO1)
elseif(i3 .eq. 1) then
CALL WDialogPutRadioButton(IDF_RADIO2)
endif
CALL WDialogPutReal(IDF_REAL1,EREF)
CALL WDialogShow(-1,-1,0,Modal)
ierr=infoerror(1)
do
!
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
call wdialogGetCheckBox(idf_check1,I1)
call wdialogGetCheckBox(idf_check2,I4A)
call wdialogGetRadioButton(idf_radio1,IPOS)
IF(IPOS .EQ. 1) THEN
I2=1
I3=0
ELSEIF(IPOS .EQ. 2) THEN
I2=0
I3=1
ELSE
I2=0
I3=0
ENDIF
CALL WDialoggetReal(IDF_REAL1,EREF)
GO TO 100
ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
I1=-1
I2=0
I3=0
WRITE(90,*) 'CANCEL',I1,I2,I3,I4A
return
ENDIF
enddo
100 CONTINUE
WRITE(90,*) 'IN CHKOPT',I1,I2,I3,I4A
IF(I4A .NE. 0) THEN
call wdialogload(IDD_CHK1DOPT)
ierr=infoerror(1)
CALL WDialogSelect(IDD_CHK1DOPT)
ierr=infoerror(1)
if(i4 .le. 1) then
CALL WDialogPutRadioButton(IDF_RADIO1)
elseif(i4 .eq. 2) then
CALL WDialogPutRadioButton(IDF_RADIO2)
endif
CALL WDialogPutReal(IDF_REAL1,WIDEL)
CALL WDialogShow(-1,-1,0,Modal)
do
!
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
call wdialogGetRadioButton(idf_radio1,I4)
CALL WDialogGetReal(IDF_REAL1,WIDEL)
WRITE(90,*) 'OUT OF CHKOPT',I1,I2,I3,I4A
return
ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
I4=0
I4A=0
ENDIF
enddo
ENDIF
WRITE(90,*) 'OUT OF CHKOPT',I1,I2,I3,I4A
return
end