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.
279 lines
7.6 KiB
Fortran
279 lines
7.6 KiB
Fortran
SUBROUTINE GETCRS(CRSTIT)
|
|
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
|
|
CHARACTER*8 ID1
|
|
CHARACTER*72 DLIN1,CRSTIT
|
|
|
|
!IPK JUN06
|
|
DATA VOIDCR/-1.E15/
|
|
MCRS=0
|
|
MPTS=00
|
|
DO
|
|
call ginpt(icrin,id1,dlin1)
|
|
IF(ID1(1:3) .EQ. 'ICS') THEN
|
|
READ(DLIN1,'(I8)') MILCT
|
|
MCRS=MAX(MILCT,MCRS)
|
|
MPTCT=0
|
|
DO
|
|
call ginpt(icrin,id1,dlin1)
|
|
IF(ID1(1:3) .EQ. 'CRS') THEN
|
|
MPTCT=MPTCT+1
|
|
ELSE
|
|
MPTS=MAX(MPTCT,MPTS)
|
|
EXIT
|
|
ENDIF
|
|
ENDDO
|
|
ELSEIF(ID1(1:7) .EQ. 'ENDDATA') THEN
|
|
REWIND (ICRIN)
|
|
EXIT
|
|
ENDIF
|
|
ENDDO
|
|
|
|
ALLOCATE (IVMIL(MCRS),NRIVL(MCRS),NOREACH(MCRS)&
|
|
,CRSDAT(MCRS,-4:MPTS,3),XCRS(MCRS),YCRS(MCRS))
|
|
|
|
XCRS=VOIDCR
|
|
YCRS=VOIDCR
|
|
NRIVCR1=0
|
|
NRIVCR2=0
|
|
!ipk jun11
|
|
NOREACH=0
|
|
NRIVL=0
|
|
IVMIL=0
|
|
WTRIVCR1=0.
|
|
WTRIVCR2=0.
|
|
|
|
call ginpt(icrin,id1,dlin1)
|
|
|
|
IF(ID1(1:2) .EQ. 'TC') THEN
|
|
CRSTIT=DLIN1
|
|
call ginpt(icrin,id1,dlin1)
|
|
ELSE
|
|
CALL WMessageBox(0,3,1,'Cross-section Title not found'//char(13)//&
|
|
'Cross-section file input terminated','ERROR')
|
|
return
|
|
ENDIF
|
|
N=0
|
|
|
|
200 N=N+1
|
|
IF(N .GT. MCRS+1) THEN
|
|
CALL WMessageBox(0,3,1,'Allowable number of sections (1000) exceeded'//char(13)//&
|
|
'Cross-section file input terminated','ERROR')
|
|
return
|
|
ENDIF
|
|
IF(ID1(1:3) .EQ. 'RCH') THEN
|
|
READ(DLIN1,'(I8)') NOREACHTMP
|
|
write(90,'(a)') 'rch',id1,dlin1
|
|
Call ginpt(icrin,id1,dlin1)
|
|
ENDIF
|
|
|
|
IF(ID1(1:3) .EQ. 'ICS') THEN
|
|
READ(DLIN1,'(2I8,8x,2f16.0)') IVMIL(N),NRIVL(IVMIL(N)),XCRS(IVMIL(N)),YCRS(IVMIL(N))
|
|
|
|
!
|
|
! IVMIL = CROSS-SECTION NUMBER
|
|
! NRIVL = NUMBER OF POINTS IN SECTION
|
|
! NOREACH = REACH/TYPE NUMBER
|
|
! CRSDAT 1 = ELEVATION
|
|
! CRSDAT 2 = AREA
|
|
! CRSDAT 3 = WIDTH
|
|
|
|
write(90,'(a)') 'ics',id1,dlin1
|
|
NOREACH(IVMIL(N))=NOREACHTMP
|
|
IF(NRIVL(IVMIL(N)) .GT. MPTS) THEN
|
|
CALL WMessageBox(0,3,1,'Allowable number of points in a cross-section (75) exceeded'//char(13)//&
|
|
'Cross-section file input terminated','ERROR')
|
|
return
|
|
ENDIF
|
|
! IF(NOREACH(N) .EQ. 0) THEN
|
|
! IF(N .GT. 1) THEN
|
|
! NOREACH(N)=NOREACH(N-1)
|
|
! ELSE
|
|
! NOREACH(N)=1
|
|
! ENDIF
|
|
! ENDIF
|
|
call ginpt(icrin,id1,dlin1)
|
|
DO I=1,NRIVL(IVMIL(N))
|
|
write(90,'(a)') 'crs',id1,dlin1
|
|
READ(DLIN1,'(3F8.0)') (CRSDAT(IVMIL(N),I,J),J=1,3)
|
|
!IPK JUN04
|
|
if(i .gt. 1) then
|
|
CRSDAT(IVMIL(N),I,2)=CRSDAT(IVMIL(N),I-1,2)+&
|
|
(CRSDAT(IVMIL(N),I,1)-CRSDAT(IVMIL(N),I-1,1))*&
|
|
(CRSDAT(IVMIL(N),I,3)+CRSDAT(IVMIL(N),I-1,3))/2.
|
|
endif
|
|
call ginpt(icrin,id1,dlin1)
|
|
ENDDO
|
|
NCRSEC=N
|
|
! TEST NCRSEC=MAX(N,IVMIL(N))
|
|
GO TO 200
|
|
ENDIF
|
|
|
|
!ipk jun06 DO N=1,NCRSEC
|
|
|
|
DO N=1,MCRS
|
|
IF(ID1(1:3) .EQ. 'XYL') THEN
|
|
READ(DLIN1,'(I8,2F16.0)') NN,XCRS(NN),YCRS(NN)
|
|
!IPK JUN06
|
|
IF(NN .GT. NCRSEC) NCRSEC=NN
|
|
call ginpt(icrin,id1,dlin1)
|
|
ELSE
|
|
GO TO 400
|
|
ENDIF
|
|
ENDDO
|
|
|
|
400 CONTINUE
|
|
DO N=1,MAXP
|
|
IF(ID1(1:3) .EQ. 'CRF') THEN
|
|
READ(DLIN1,'(2I8,F8.0,I8,F8.0)') NODCRS&
|
|
,NRIVCR1(NODCRS),WTRIVCR1(NODCRS)&
|
|
,NRIVCR2(NODCRS),WTRIVCR2(NODCRS)
|
|
call ginpt(icrin,id1,dlin1)
|
|
ELSE
|
|
GO TO 500
|
|
ENDIF
|
|
ENDDO
|
|
500 CONTINUE
|
|
|
|
CLOSE(ICRIN)
|
|
|
|
! CHECK THE DATA LOADED
|
|
|
|
IERR=0
|
|
DO N=1,NE
|
|
IF(IMAT(N) .LT. 900) THEN
|
|
IF(NCORN(N) .EQ. 3 .OR. NCORN(N) .EQ. 5) THEN
|
|
DO J=1,3,2
|
|
IF(NRIVCR1(NOP(N,J)) .NE. 0) THEN
|
|
WD1(NOP(N,J))=&
|
|
CRSDAT(NRIVCR1(NOP(N,J)),1,1)*WTRIVCR1(NOP(N,J))+&
|
|
CRSDAT(NRIVCR2(NOP(N,J)),1,1)*WTRIVCR2(NOP(N,J))
|
|
! ELSE
|
|
! WRITE(75,*) ' NO CROSS-SECTION FILE REFERENCE FOR',NOP(N,J)
|
|
! WRITE(75,*) ' EXECUTION TERMINATED'
|
|
! WRITE(*,*) ' NO CROSS-SECTION FILE REFERENCE FOR',NOP(N,J)
|
|
! WRITE(*,*) ' EXECUTION TERMINATED'
|
|
! IERR=IERR+1
|
|
ELSE
|
|
WD1(NOP(N,J))=WD(NOP(N,J))
|
|
ENDIF
|
|
!
|
|
ENDDO
|
|
|
|
IF(NOP(N,2) .GT. 0) WD1(NOP(N,2))=(WD1(NOP(N,1))+WD1(NOP(N,3)))/2.
|
|
!
|
|
ELSE
|
|
DO J=1,NCORN(N)
|
|
WD1(NOP(N,J))=WD(NOP(N,J))
|
|
ENDDO
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
|
|
RETURN
|
|
END
|
|
|
|
SUBROUTINE WRTCRS(ICROUT,CRSTIT)
|
|
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
! COMMON/ICN1/ ICN(MAXP)
|
|
|
|
|
|
CHARACTER*8 ID1,ENDDAT
|
|
CHARACTER*72 CRSTIT
|
|
|
|
!IPK JUN06
|
|
DATA VOIDCRP/-1.E14/
|
|
|
|
DO J=1,MAXP
|
|
ICN(J)=0
|
|
END DO
|
|
! First sort out the potential midsides
|
|
! Note that transition elements caues a problem
|
|
! Find these first
|
|
DO 200 N=1,NE
|
|
if(NCORN(N) .GT. 5) GO TO 200
|
|
IF(NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN
|
|
!
|
|
! We have a transition mark node number as if it were corner
|
|
!
|
|
ICN(NOP(N,3))=1
|
|
ICN(NOP(N,1))=2
|
|
ICN(NOP(N,4))=2
|
|
ICN(NOP(N,5))=2
|
|
ELSE
|
|
!
|
|
! Store ICN = 2 for corner nodes
|
|
!
|
|
NCN=NCORN(N)
|
|
!IPKOCT93 IF(IMAT(N) .GT. 900) THEN
|
|
IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN
|
|
MST=1
|
|
ELSE
|
|
MST=2
|
|
ENDIF
|
|
|
|
DO 180 M=1,NCN,MST
|
|
|
|
ICN(NOP(N,M))=2
|
|
180 CONTINUE
|
|
ENDIF
|
|
200 END DO
|
|
ID1='TC '
|
|
WRITE(ICROUT,'(A8,A72)') ID1,CRSTIT
|
|
|
|
|
|
DO N=1,NCRSEC
|
|
!ipk jun06
|
|
!! IF(NRIVL(N) .GT. 0) THEN
|
|
ID1='RCH '
|
|
WRITE(ICROUT,'(A8,I8)') ID1,NOREACH(IVMIL(N))
|
|
ID1='ICS '
|
|
!! write(icrout,'(A8,2I8,8x,2f16.4)') ID1,IVMIL(N),NRIVL(N),XCRS(N),YCRS(N)
|
|
!!jul15 write(icrout,'(A8,2I8,8x,2f16.4)') ID1,N,NRIVL(N),XCRS(N),YCRS(N)
|
|
write(icrout,'(A8,2I8,8x,2f16.4)') ID1,IVMIL(N),NRIVL(IVMIL(N)),XCRS(IVMIL(N)),YCRS(IVMIL(N))
|
|
ID1='CRS '
|
|
DO I=1,NRIVL(IVMIL(N))
|
|
if(crsdat(IVMIL(N),i,2) .gt. 999999.) then
|
|
WRITE(ICROUT,'(A8,3F8.0)') ID1,(CRSDAT(IVMIL(N),I,J),J=1,3)
|
|
elseif(crsdat(IVMIL(N),i,2) .gt. 99999.) then
|
|
WRITE(ICROUT,'(A8,3F8.1)') ID1,(CRSDAT(IVMIL(N),I,J),J=1,3)
|
|
else
|
|
WRITE(ICROUT,'(A8,3F8.2)') ID1,(CRSDAT(IVMIL(N),I,J),J=1,3)
|
|
endif
|
|
ENDDO
|
|
!ipk jun06
|
|
!! ENDIF
|
|
ENDDO
|
|
|
|
|
|
DO N=1,NCRSEC
|
|
!ipk jun06
|
|
IF(XCRS(N) .GT. VOIDCRP) THEN
|
|
ID1='XYL '
|
|
WRITE(ICROUT,'(A8,I8,2F16.4)') ID1,IVMIL(N),XCRS(IVMIL(N)),YCRS(IVMIL(N))
|
|
!ipk jun06
|
|
ENDIF
|
|
ENDDO
|
|
|
|
ID1='CRF '
|
|
DO N=1,NP
|
|
IF(ICN(N) .EQ. 2) THEN
|
|
IF(NRIVCR1(N) .GT. 0) THEN
|
|
WRITE(ICROUT,'(A8,2I8,F8.4,I8,F8.4)') ID1,N&
|
|
,NRIVCR1(N),WTRIVCR1(N)&
|
|
,NRIVCR2(N),WTRIVCR2(N)
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
|
|
ENDDAT='ENDDATA '
|
|
WRITE(ICROUT,'(A8)') ENDDAT
|
|
RETURN
|
|
END
|
|
|
|
|