-
Notifications
You must be signed in to change notification settings - Fork 5
/
Copy pathdvest.f
150 lines (139 loc) · 5.28 KB
/
dvest.f
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
!== last modified 01-18-2013
C 01/18/2013 Added calculation for cordwood VOL(6) for region 1,2,4,5,10
C 2018/08/01 YW Added call to HAHN_NC250 for Region 9
! 2018/09/05 ADDED PROD AND MTOPP TO CALL R2OLDV
C 2019/04/04 YW added call to Canadian Honer equation for BIA
C 2022/08/08 YW added variable STUMP to DVEST
C SUBROUTINE FINDS VOLUMES USING DIRECT VOLUME ESTIMATORS
SUBROUTINE DVEST(VOLEQ,DBHOB,DRC,HTTOT,MTOPP,FCLASS,HTLOG,HT1PRD,
> HT2PRD,FORST,BTR,VOL,CUTFLG,BFPFLG,CUPFLG,CDPFLG,
> SPFLG,PROD,HTTYPE,HTTFLL,NOLOGP,LIVE,BA,SI,
> CTYPE,ERRFLAG,MTOPS,STUMP)
CHARACTER*10 VOLEQ
CHARACTER*1 HTTYPE,LIVE,CTYPE
CHARACTER*2 FORST,PROD
INTEGER FCLASS,UNIT,HTLOG,BA,SI
INTEGER CUTFLG,BFPFLG,CUPFLG,CDPFLG,SPFLG
integer HTTFLL,ERRFLAG
REAL DBHOB,HTTOT,VOL(15),HT1PRD,HT2PRD,NOLOGP,BTR
REAL MTOPP,STUMP,BDVOL,CUVOL,TCVOL,DRC,MTOPS
DO 100, I=1,15
VOL(I) = 0.0
100 CONTINUE
C DIRECT VOLUME ESTIMATOR LOGIC
IF(VOLEQ(1:1).EQ.'1') THEN
C*****************************
C REGION 1 D2H ROUTINES *
C*****************************
IF (VOLEQ(2:3).EQ.'02' .OR. VOLEQ(2:3).EQ.'03' .OR.
> VOLEQ(2:3).EQ.'04' .OR. VOLEQ(2:3).EQ.'05' .OR.
> VOLEQ(2:3).EQ.'06') THEN
c KEMP
CALL R1KEMP(VOLEQ,HTTOT,DBHOB,VOL,LIVE,PROD,NOLOGP,ERRFLAG)
ENDIF
C BOARD FOOT KEMP
IF (VOLEQ(2:3).EQ.'01' .AND. BFPFLG.EQ.1) THEN
IF((VOLEQ(8:10).EQ.'108' .AND. DBHOB.GE.6)
> .OR. DBHOB.GE.7)THEN
STUMP=1.0
CALL R1ALLENB (VOLEQ,DBHOB,HTTOT,MTOPP,BTR,BDVOL,STUMP,
> ERRFLAG)
VOL(2) = BDVOL
ELSE
VOL(2) = 0.0
ENDIF
ENDIF
C CUBIC KEMP
IF(VOLEQ(2:3).EQ.'01' .AND. (CUPFLG.EQ.1 .or. CUTFLG.EQ.1))THEN
STUMP = 1.0
c byrne
CALL R1ALLENC(VOLEQ,DBHOB,HTTOT,MTOPP,BTR,CUVOL,TCVOL,STUMP,
> ERRFLAG)
VOL(1) = TCVOL
VOL(4) = CUVOL
ENDIF
IF(VOLEQ(2:3).EQ.'07')THEN
STUMP = 1.0
ENDIF
VOL(6)=VOL(4)/90
ELSEIF(VOLEQ(1:1).EQ.'2') THEN
C*****************************
C REGION 2 D2H ROUTINES *
C*****************************
CALL R2OLDV(VOLEQ,HTTOT,DBHOB,DRC,FCLASS,VOL,ERRFLAG,PROD,MTOPP)
VOL(6)=(VOL(4)+VOL(7))/90
ELSEIF(VOLEQ(1:1).EQ.'3') THEN
C*****************************
C REGION 3 D2H ROUTINES *
C*****************************
C--------- SAWTIMBER TREES
IF (PROD.EQ.'01') THEN
UNIT = 1
CALL R3D2HV (VOLEQ,UNIT,HTTOT,HT1PRD,DBHOB,DRC,FCLASS,HTTFLL,
> VOL,ERRFLAG)
C-------------- PULPWOOD TREES
ELSE
UNIT = 3
CALL R3D2HV(VOLEQ,UNIT,HTTOT,HT1PRD,DBHOB,DRC,FCLASS,HTTFLL,
> VOL,ERRFLAG)
ENDIF
ELSEIF(VOLEQ(1:1).EQ.'4') THEN
C*****************************
C REGION 4 D2H ROUTINES *
C*****************************
CALL R4D2H (VOLEQ,HTTOT,DBHOB,DRC,FCLASS,VOL,ERRFLAG)
VOL(6)=VOL(4)/90
ELSEIF(VOLEQ(1:1).EQ.'5') THEN
C*****************************
C REGION 5 D2H ROUTINES *
C*****************************
CALL R5HARV(VOLEQ,DBHOB,HTTOT,MTOPP,VOL,BFPFLG,CUPFLG,ERRFLAG)
VOL(6)=VOL(4)/90
ELSEIF(VOLEQ(1:1).EQ.'9') THEN
IF(VOLEQ(2:3).EQ.'25')THEN
CALL HAHN_NC250(VOLEQ,HTTOT,HT1PRD,HT2PRD,DBHOB,VOL,SI,BA,
> PROD,CTYPE,BFPFLG,CUPFLG,SPFLG,ERRFLAG,MTOPP,MTOPS)
ELSE
C*****************************
C REGION 9 D2H ROUTINES *
C*****************************
CALL R9VOL(VOLEQ,HTTOT,HT1PRD,HT2PRD,DBHOB,VOL,FORST,SI,BA,
* PROD,CTYPE,BFPFLG,CUPFLG,CDPFLG,SPFLG,HTTYPE,ERRFLAG,MTOPP)
ENDIF
ELSEIF(VOLEQ(1:1).EQ.'A' .or. VOLEQ(1:1).EQ.'a') THEN
C*****************************
C REGION 10 D2H ROUTINES *
C*****************************
CALL R10D2H(VOLEQ,DBHOB,HTTOT,VOL,CUTFLG,CUPFLG,BFPFLG,
> MTOPP,ERRFLAG)
VOL(6)=VOL(4)/90
ELSEIF(VOLEQ(1:1).EQ.'M' .or. voleq(1:1).eq.'m') THEN
C******************************
C ARMY BASE D2H ROUTINES *
C******************************
IF(HTTYPE.EQ.'L' .OR. HTTYPE.EQ.'l') THEN
IF(VOLEQ(1:3).EQ.'M01' .OR. VOLEQ(1:3).eq.'m01') THEN
CALL DOYAL78(DBHOB,HT1PRD,VOL,ERRFLAG)
ELSEIF(VOLEQ(1:3).EQ.'M02' .or. VOLEQ(1:3).eq.'m02') THEN
CALL INTL78(DBHOB,HT1PRD,VOL,ERRFLAG)
ENDIF
ELSE
ERRFLAG = 7
ENDIF
ELSEIF(VOLEQ(1:1).EQ.'C' .or. voleq(1:1).eq.'c') THEN
C******************************
C Canadian Honor Equation used by BIA in eastern region*
C******************************
CALL Voleq_Honer(VOLEQ,DBHOB,HTTOT,MTOPP,MTOPS,
& VOL,ERRFLAG)
ENDIF
C ROUND ALL VOLUMES 10TH CUBIC AND CORD, NEAREST BDFT
VOL(1) = ANINT(VOL(1)*10.0)/10.0
VOL(2) = ANINT(VOL(2))
VOL(4) = ANINT(VOL(4)*10.0)/10.0
VOL(6) = ANINT(VOL(6)*1000.0)/1000.0
VOL(7) = ANINT(VOL(7)*10.0)/10.0
VOL(9) = ANINT(VOL(9)*1000.0)/1000.0
VOL(10) = ANINT(VOL(10))
RETURN
END