298 lines
8.7 KiB
FortranFixed
298 lines
8.7 KiB
FortranFixed
|
SUBROUTINE INCM55(PO,JN,NU,XFACT,NQL,X,LQ1,LQN,CM,CML,CMR,STT,
|
||
|
|
1 LTSTT,QL,LTQL,ST1,LTST1,HS,SLFI,NUMLAD,LAD,NQCM,NJUN,YQCM,NRCM1,
|
||
|
|
2 NCM,NB,QUSJ,LTQUSJ,YQR,MRV,IORDR,K1,K2,K4,K7,K8,K9,K10)
|
||
|
|
C
|
||
|
|
C THIS SUBROUTINE CALCULATES MANNING'S N IF ZERO VALUES ARE GIVEN
|
||
|
|
|
||
|
|
C
|
||
|
|
COMMON/M3255/IOBS,KTERM,KPL,JNK,TEH
|
||
|
|
COMMON/SS55/NCS,A,B,DB,R,DR,AT,BT,P,DP,ZH
|
||
|
|
COMMON/FLP55/KFLP
|
||
|
|
COMMON/NPC55/NP,NPST,NPEND
|
||
|
|
COMMON/IONUM/IN,IPR,IPU
|
||
|
|
COMMON/IDOS55/IDOS,IFCST
|
||
|
|
|
||
|
|
INCLUDE 'common/fdbug'
|
||
|
|
INCLUDE 'common/ofs55'
|
||
|
|
C
|
||
|
|
DIMENSION PO(*),ST1(*),LTST1(*),STT(*),LTSTT(*),QL(*),LTQL(*)
|
||
|
|
DIMENSION QUSJ(*),LTQUSJ(*),NQL(K1),X(K2,K1),MRV(K1),IORDR(K1)
|
||
|
|
DIMENSION LQ1(K10,K1),LQN(K10,K1),NJUN(K1),YQR(K8)
|
||
|
|
DIMENSION NRCM1(K1),NCM(K7,K1),NQCM(K1),NUMLAD(K1),LAD(K4,K1)
|
||
|
|
DIMENSION YQCM(K8,K7,K1),CM(K8,K7,K1),CML(K8,K7,K1),CMR(K8,K7,K1)
|
||
|
|
DIMENSION HS(K9,K2,K1),NB(K1),SLFI(K2,K1)
|
||
|
|
CHARACTER*8 SNAME
|
||
|
|
|
||
|
|
C
|
||
|
|
C ================================= RCS keyword statements ==========
|
||
|
|
CHARACTER*68 RCSKW1,RCSKW2
|
||
|
|
DATA RCSKW1,RCSKW2 / '
|
||
|
|
.$Source: /fs/hseb/ob72/rfc/ofs/src/fcst_fldwav/RCS/incm55.f,v $
|
||
|
|
. $', '
|
||
|
|
.$Id: incm55.f,v 1.2 2000/12/19 15:51:59 dws Exp $
|
||
|
|
. $' /
|
||
|
|
C ===================================================================
|
||
|
|
C
|
||
|
|
|
||
|
|
DATA SNAME/ 'INCM55 ' /
|
||
|
|
C
|
||
|
|
CALL FPRBUG(SNAME,1,55,IBUG)
|
||
|
|
|
||
|
|
IF(NP.GE.0) GO TO 500
|
||
|
|
|
||
|
|
C ... DETERMINE TOTAL INFLOW INTO SYSTEM FOR EACH TRIBUTARY
|
||
|
|
DO 18 L=1,NU
|
||
|
|
DO 16 M=1,JN
|
||
|
|
J=IORDR(JN-M+1)
|
||
|
|
LQJ=LTQUSJ(J)-1
|
||
|
|
LS1=LTST1(J)-1
|
||
|
|
QUSJ(LQJ+J)=ST1(LS1+J)
|
||
|
|
DO 12 J1=1,JN
|
||
|
|
LQJ1=LTQUSJ(J1)-1
|
||
|
|
IF(MRV(J1).EQ.J) QUSJ(LQJ+J)=QUSJ(LQJ+J)+QUSJ(L+LQJ1)
|
||
|
|
12 CONTINUE
|
||
|
|
NQ=NQL(J)
|
||
|
|
LKJ=LTQL(K)
|
||
|
|
IF(NQ.GT.0) THEN
|
||
|
|
DO 14 K=1,NQ
|
||
|
|
KJ=LCAT21(K,J,NQL)
|
||
|
|
LKJ=LTQL(KJ)-1
|
||
|
|
IQQ=LQ1(K,J)
|
||
|
|
LQQ=LQN(K,J)
|
||
|
|
DX=1.
|
||
|
|
IF(IDOS.LT.3) DX=ABS(X(LQQ,J)-X(IQQ,J))*XFACT
|
||
|
|
QUSJ(L+LQJ)=QUSJ(L+LQJ)+QL(L+LKJ)*DX
|
||
|
|
14 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
16 CONTINUE
|
||
|
|
18 CONTINUE
|
||
|
|
|
||
|
|
DO 70 M=1,JN
|
||
|
|
J=IORDR(JN-M+1)
|
||
|
|
LS1=LTST1(J)-1
|
||
|
|
NAT=NRCM1(J)
|
||
|
|
NCML=IABS(NQCM(J))
|
||
|
|
IF(NCML.EQ.0) NCML=NCS
|
||
|
|
DO 65 LK=1,NAT
|
||
|
|
IF(CM(2,LK,J).GT.0.001) GO TO 65
|
||
|
|
I1=NCM(LK,J)
|
||
|
|
IF(LK.LT.NAT) IND=NCM(LK+1,J)
|
||
|
|
IF(LK.EQ.NAT) IND=NB(J)
|
||
|
|
YQR(1)=0.
|
||
|
|
IF(YQCM(1,LK,J).LT.0.0) YQR(1)=YQCM(1,LK,J)
|
||
|
|
DO 102 KK=2,NCML
|
||
|
|
YQR(KK)=0.5*(YQCM(KK-1,LK,J)+YQCM(KK,LK,J))
|
||
|
|
102 CONTINUE
|
||
|
|
DO 50 KK=1,NCML
|
||
|
|
CSUM=0.
|
||
|
|
LL=0
|
||
|
|
DO 20 L=1,NU
|
||
|
|
QUS=ST1(L+LS1)
|
||
|
|
IF(JN.EQ.1) GO TO 4
|
||
|
|
DO 2 J1=1,JN
|
||
|
|
LQJ1=LTQUSJ(J1)-1
|
||
|
|
IF(MRV(J1).EQ.J.AND.I1.GE.NJUN(J1)) QUS=QUS+QUSJ(L+LQJ1)
|
||
|
|
2 CONTINUE
|
||
|
|
CC IF(J.GT.1) GO TO 4
|
||
|
|
CC DO 103 J1=2,JN
|
||
|
|
CC NJN=NJUN(J1)
|
||
|
|
CC IF(I1.GE.NJN) QUS=QUS+ST1(L,J1)
|
||
|
|
CC 103 CONTINUE
|
||
|
|
4 IF(NQL(J).EQ.0) GO TO 6
|
||
|
|
NQ=NQL(J)
|
||
|
|
DO 5 I=1,NQ
|
||
|
|
IJ=LCAT21(I,J,NQL)
|
||
|
|
LIJ=LTQL(IJ)-1
|
||
|
|
IQQ=LQ1(I,J)
|
||
|
|
LQQ=LQN(I,J)
|
||
|
|
IF(I1.GE.LQQ) THEN
|
||
|
|
DX=1.
|
||
|
|
IF(IDOS.LT.3) DX=ABS(X(LQQ+1,J)-X(IQQ,J))*XFACT
|
||
|
|
QUS=QUS+QL(L+LIJ)*DX
|
||
|
|
END IF
|
||
|
|
5 CONTINUE
|
||
|
|
6 II=LK
|
||
|
|
IIJ=LCAT21(II,J,NGAGE)
|
||
|
|
LIIJ=LTSTT(IIJ)-1
|
||
|
|
LI1J=LTSTT(IIJ+1)-1
|
||
|
|
IF(NQCM(J).LT.0) GO TO 7
|
||
|
|
STA=0.5*(STT(L+LIIJ)+STT(L+LI1J))
|
||
|
|
IF(KK.LT.NCML.AND.STA.GT.YQR(KK).AND.STA.LE.YQR(KK+1)) GO TO 8
|
||
|
|
GO TO 20
|
||
|
|
7 IF(QUS.GT.-10.0.AND.QUS.LT.10.0)GO TO 20
|
||
|
|
IF(KK.LT.NCML.AND.QUS.GT.YQR(KK).AND.QUS.LE.YQR(KK+1)) GO TO 8
|
||
|
|
GO TO 20
|
||
|
|
8 DH=STT(L+LIIJ)-STT(L+LI1J)
|
||
|
|
DXL=ABS(X(IND,J)-X(I1,J))*XFACT
|
||
|
|
S=ABS(DH/DXL)
|
||
|
|
NUML=NUMLAD(J)
|
||
|
|
IF(NUML.EQ.0) GO TO 9
|
||
|
|
DO 109 LLK=1,NUML
|
||
|
|
LDD=IABS(LAD(LLK,J))
|
||
|
|
IF(LDD.GE.I1.AND.LDD.LT.IND) S=0.5*(SLFI(I1,J)+SLFI(IND,J))
|
||
|
|
109 CONTINUE
|
||
|
|
9 SA=0.
|
||
|
|
SB=0.
|
||
|
|
DO 125 I=I1,IND
|
||
|
|
DXX=ABS(X(I1,J)-X(I,J))*XFACT
|
||
|
|
IF(I.EQ.I1) H=STT(L+LIIJ)
|
||
|
|
IF(I.EQ.I1) GO TO 115
|
||
|
|
IF(I.EQ.IND) H=STT(L+LI1J)
|
||
|
|
IF(I.EQ.IND) GO TO 117
|
||
|
|
H=STT(L+LIIJ)-DH*DXX/DXL
|
||
|
|
GO TO 117
|
||
|
|
115 CALL SECT55(PO(LCPR),PO(LOAS),PO(LOBS),HS,PO(LOASS),PO(LOBSS),
|
||
|
|
. J,I,H,PO(LCHCAV),PO(LCIFCV),K1,K2,K9)
|
||
|
|
AU=A
|
||
|
|
BU=B
|
||
|
|
GO TO 125
|
||
|
|
117 CALL SECT55(PO(LCPR),PO(LOAS),PO(LOBS),HS,PO(LOASS),PO(LOBSS),
|
||
|
|
. J,I,H,PO(LCHCAV),PO(LCIFCV),K1,K2,K9)
|
||
|
|
DX=ABS(X(I,J)-X(I-1,J))*XFACT
|
||
|
|
SA=SA+0.5*(AU+A)*DX
|
||
|
|
SB=SB+0.5*(BU+B)*DX
|
||
|
|
AU=A
|
||
|
|
BU=B
|
||
|
|
125 CONTINUE
|
||
|
|
AAV=SA/DXL
|
||
|
|
BAV=SB/DXL
|
||
|
|
CN=1.486/ABS(QUS)*AAV*(AAV/BAV)**(2./3.)*SQRT(S)
|
||
|
|
IF(CN.LT.0.003)CN=0.003
|
||
|
|
IF(CN.GT.0.20)CN=0.20
|
||
|
|
CSUM=CSUM+CN
|
||
|
|
LL=LL+1
|
||
|
|
20 CONTINUE
|
||
|
|
IF(LL.EQ.0) CM(KK,LK,J)=0.020
|
||
|
|
IF(LL.GT.0) CM(KK,LK,J)=CSUM/LL
|
||
|
|
IF(IBUG.GE.1) WRITE(IODBUG,72)LL,CM(KK,LK,J)
|
||
|
|
72 FORMAT(2X,3HLL=,I2,20X,F10.4)
|
||
|
|
50 CONTINUE
|
||
|
|
DO 52 L=1,NCML
|
||
|
|
LL=L
|
||
|
|
IF(CM(L,LK,J).GT.0.001) GO TO 54
|
||
|
|
52 CONTINUE
|
||
|
|
54 IF(LL.EQ.1) GO TO 58
|
||
|
|
LL=LL-1
|
||
|
|
DO 56 L=1,LL
|
||
|
|
56 CM(L,LK,J)=CM(LL+1,LK,J)
|
||
|
|
58 DO 60 L=1,NCML
|
||
|
|
LL=L
|
||
|
|
IF(CM(L,LK,J).LT.0.001) CM(L,LK,J)=CM(L-1,LK,J)
|
||
|
|
60 CONTINUE
|
||
|
|
IF(IBUG.GE.1) WRITE(IODBUG,73)LK,J
|
||
|
|
73 FORMAT(5X,6H(CM(L,,I2,1H,,I1,11H),L=1,NCML))
|
||
|
|
IF(IBUG.GE.1) WRITE(IODBUG,74)(CM(L,LK,J),L=1,NCML)
|
||
|
|
74 FORMAT(12F10.4)
|
||
|
|
65 CONTINUE
|
||
|
|
70 CONTINUE
|
||
|
|
C INTERPOLATE MANNING N CURVE FOR ALL INPUT CROSS SECTION REACHES
|
||
|
|
DO 590 J=1,JN
|
||
|
|
IF(KFLP.GE.1) NQCM(J)=0
|
||
|
|
C KFLP>0, USE CONVEYANCE; IMPLY NQCM=0
|
||
|
|
C NQCM=>0 MANNING N IS FCN OF H; <0 MANNING N IS FCN OF Q
|
||
|
|
NQCMJ=NQCM(J)
|
||
|
|
NCML=ABS(NQCMJ)
|
||
|
|
IF(NCML.LE.0) NCML=NCS
|
||
|
|
NRCM=NRCM1(J)
|
||
|
|
DO 590 II=1,NRCM
|
||
|
|
I=NRCM-II+1
|
||
|
|
IS=NCM(I,J)
|
||
|
|
DO 580 K=1,NCML
|
||
|
|
CM(K,IS,J)=CM(K,I,J)
|
||
|
|
IF(KFLP.EQ.1) THEN
|
||
|
|
CML(K,IS,J)=CML(K,I,J)
|
||
|
|
CMR(K,IS,J)=CMR(K,I,J)
|
||
|
|
ENDIF
|
||
|
|
580 YQCM(K,IS,J)=YQCM(K,I,J)
|
||
|
|
590 CONTINUE
|
||
|
|
CC DO 870 J=1,JN
|
||
|
|
CC N=NB(J)
|
||
|
|
CC NM=N-1
|
||
|
|
CC IF(KFLP.GE.1) NQCM(J)=0
|
||
|
|
CC NQCMJ=NQCM(J)
|
||
|
|
CC NCML=ABS(NQCMJ)
|
||
|
|
CC IF(NCML.EQ.0) NCML=NCS
|
||
|
|
CC NRCM=NRCM1(J)
|
||
|
|
CC DO 769 II=1,NRCM
|
||
|
|
CC IIP1=II+1
|
||
|
|
CC IS=NCM(II,J)
|
||
|
|
CC IE=NCM(IIP1,J)
|
||
|
|
CC IF(II.EQ.NRCM) IE=N
|
||
|
|
CC NPT=IE-IS-1
|
||
|
|
CC IF(NPT.LE.0) GO TO 761
|
||
|
|
CC DO 760 I=1,NPT
|
||
|
|
CC IPT=IS+I
|
||
|
|
CC DO 760 K=1,NCML
|
||
|
|
CC 760 CM(K,IPT,J)=CM(K,IS,J)
|
||
|
|
CC 761 IF(NQCMJ.NE.0) GO TO 764
|
||
|
|
CCC NQCM<>0, USE MANNING EQUATION, IMPLY KFLP=0
|
||
|
|
CC IF(KFLP.EQ.0) GO TO 768
|
||
|
|
CC IF(NPT.LE.0) GO TO 768
|
||
|
|
CC DO 762 I=1,NPT
|
||
|
|
CC IPT=IS+I
|
||
|
|
CC DO 762 K=1,NCML
|
||
|
|
CC CML(K,IPT,J)=CML(K,IS,J)
|
||
|
|
CC 762 CMR(K,IPT,J)=CMR(K,IS,J)
|
||
|
|
CC GO TO 768
|
||
|
|
CC 764 IF(NPT.LE.0) GO TO 768
|
||
|
|
CC DO 766 I=1,NPT
|
||
|
|
CC IPT0=IS+I-1
|
||
|
|
CC IPT=IPT0+1
|
||
|
|
CCCCC IPT1=IPT+1
|
||
|
|
CC HIPT0=0.0
|
||
|
|
CC HIPT=0.0
|
||
|
|
CCC IF(NQCMJ.GT.0) THEN
|
||
|
|
CCC HIPT0=0.5*(HS(1,IPT0,J)+HS(1,IPT,J))
|
||
|
|
CCC HIPT=0.5*(HS(1,IPT,J)+HS(1,IPT1,J))
|
||
|
|
CCC ENDIF
|
||
|
|
CC DO 766 K=1,NCML
|
||
|
|
CC 766 YQCM(K,IPT,J)=YQCM(K,IPT0,J)-HIPT0+HIPT
|
||
|
|
CC 768 CONTINUE
|
||
|
|
CC 769 CONTINUE
|
||
|
|
CC IF(NRCM.EQ.N) GO TO 774
|
||
|
|
CC HNM=0.0
|
||
|
|
CC HN=0.0
|
||
|
|
CC IF(NQCMJ.GT.0) THEN
|
||
|
|
CC HNM=0.5*(HS(1,NM,J)+HS(1,N,J))
|
||
|
|
CC HN=HS(1,N,J)
|
||
|
|
CC ENDIF
|
||
|
|
CC DO 772 K=1,NCML
|
||
|
|
CC 772 YQCM(K,N,J)=YQCM(K,NM,J)-HNM+HN
|
||
|
|
CC 774 IF (NQCMJ.NE.0) GO TO 778
|
||
|
|
CC DO 775 I=1,NM
|
||
|
|
CC IP1=I+1
|
||
|
|
CC DO 775 K=1,NCS
|
||
|
|
CC 775 YQCM(K,I,J)=0.5*(HS(K,I,J)+HS(K,IP1,J))
|
||
|
|
CC DO 776 K=1,NCS
|
||
|
|
CC 776 YQCM(K,N,J)=HS(K,N,J)
|
||
|
|
CC 778 CONTINUE
|
||
|
|
CC IF(NCM(NRCM,J).EQ.N) GO TO 780
|
||
|
|
CC DO 786 K=1,NCML
|
||
|
|
CC CM(K,N,J)=CM(K,NM,J)
|
||
|
|
CC IF(KFLP.EQ.0) GO TO 786
|
||
|
|
CC CML(K,N,J)=CML(K,NM,J)
|
||
|
|
CC CMR(K,N,J)=CMR(K,NM,J)
|
||
|
|
CC 786 CONTINUE
|
||
|
|
CCCC 780 IF(JNK.LT.9.OR.IBUG.EQ.0) GO TO 870
|
||
|
|
CC 780 IF(IBUG.EQ.0) GO TO 870
|
||
|
|
CC WRITE(IODBUG,2090) J
|
||
|
|
CC 2090 FORMAT(/2X,'MANNING TABLE AT EACH SECTION REACH ON RIVER NO.',I3)
|
||
|
|
CC DO 860 I=1,N
|
||
|
|
CC WRITE(IODBUG,2091) I,J,(CM(K,I,J),K=1,NCML)
|
||
|
|
CC IF(KFLP.NE.1) GO TO 849
|
||
|
|
CC WRITE(IODBUG,2092) I,J,(CML(K,I,J),K=1,NCML)
|
||
|
|
CC WRITE(IODBUG,2093) I,J,(CMR(K,I,J),K=1,NCML)
|
||
|
|
CC 849 IF(NQCMJ.LT.0) WRITE(IPR,2094) I,J,(YQCM(K,I,J),K=1,NCML)
|
||
|
|
CC IF(NQCMJ.GE.0) WRITE(IPR,2095) I,J,(YQCM(K,I,J),K=1,NCML)
|
||
|
|
CC 860 CONTINUE
|
||
|
|
CC 870 CONTINUE
|
||
|
|
CCC WRITE(IPR,11111)
|
||
|
|
CC11111 FORMAT(1X,'** EXIT INITCM **')
|
||
|
|
CC 2091 FORMAT(5X,' CM(K,',I2,1H,,I2,')= ',10F10.4,(/19X,10F10.4))
|
||
|
|
CC 2092 FORMAT(5X,' CML(K,',I2,1H,,I2,')= ',10F10.4,(/19X,10F10.4))
|
||
|
|
CC 2093 FORMAT(5X,' CMR(K,',I2,1H,,I2,')= ',10F10.4,(/19X,10F10.4))
|
||
|
|
CC 2094 FORMAT(5X,'YQCM(K,',I2,1H,,I2,')= ',10F10.0,(/19X,10F10.0))
|
||
|
|
CC 2095 FORMAT(5X,'YQCM(K,',I2,1H,,I2,')= ',10F10.2,(/19X,10F10.2))
|
||
|
|
500 RETURN
|
||
|
|
END
|