diff --git a/f_other.f b/f_other.f index 7fa2ddd..59a1909 100644 --- a/f_other.f +++ b/f_other.f @@ -67,7 +67,7 @@ SUBROUTINE BRK_OT(JSP,geosub,DBHOB,DOB,HT2,DBTBH,DIB,dbt) C3 = BK(6,JSPR) D0 = BK(7,JSPR) D1 = BK(8,JSPR) - D2 = BK(9,JSPR) + D2 = BK(9,JSPR) c********************************************************************** C IF(HT2.LT.(THT-2.0)) THEN @@ -83,7 +83,7 @@ SUBROUTINE BRK_OT(JSP,geosub,DBHOB,DOB,HT2,DBTBH,DIB,dbt) IF (DBTBH.LE.0) THEN IF(JSPR.LE.1) THEN c Black Hills - DBHIB = DBHOB*(D0+D1*ALOG(DBHOB)) + DBHIB = REAL(DBHOB*(D0+D1*ALOG(DBHOB))) ELSE IF(JSPR.EQ.2) THEN c San Juan Model IF(GEOSUB.EQ.'07') THEN @@ -92,7 +92,7 @@ SUBROUTINE BRK_OT(JSP,geosub,DBHOB,DOB,HT2,DBTBH,DIB,dbt) C DBHIB = -0.789251+0.922976*DBHOB ELSEIF(GEOSUB.EQ.'13')THEN C Use San Juan bark model - DBHIB = DBHOB*(D0+D1*ALOG(DBHOB)) + DBHIB = REAL(DBHOB*(D0+D1*ALOG(DBHOB))) ELSE IF(GEOSUB.EQ.'01') THEN C Use A-S, Gila bark model DBHIB = -0.649171195+0.925582344*DBHOB @@ -102,7 +102,7 @@ SUBROUTINE BRK_OT(JSP,geosub,DBHOB,DOB,HT2,DBTBH,DIB,dbt) ENDIF ELSE IF(JSPR.EQ.3) THEN c Dixie Model - DBHIB = DBHOB*(D0+D1*ALOG(DBHOB)) + DBHIB = REAL(DBHOB*(D0+D1*ALOG(DBHOB))) ELSEIF (JSPR.EQ.4) THEN c R2 Lodgepole model @@ -110,20 +110,20 @@ SUBROUTINE BRK_OT(JSP,geosub,DBHOB,DOB,HT2,DBTBH,DIB,dbt) DBHIB = DBHOB*(0.925915+0.0153361 * alog(DBHOB)) ELSE C Northern Wyoming Bark Model - DBHIB = DBHOB*(D0 + D1*ALOG(DBHOB)) + DBHIB = REAL(DBHOB*(D0 + D1*ALOG(DBHOB))) ENDIF ELSE IF(JSPR.EQ.5)THEN C Douglas Fir - DBHIB = D0 + D1*DBHOB + DBHIB = REAL(D0 + D1*DBHOB) ELSE IF(JSPR.EQ.6)THEN C White fir - DBHIB = D0 + D1*DBHOB + DBHIB = REAL(D0 + D1*DBHOB) ELSE IF(JSPR.EQ.7)THEN c Aspen Model - DBHIB = D0 + D1*DBHOB + DBHIB = REAL(D0 + D1*DBHOB) ELSE IF(JSPR.EQ.8)THEN C r3 ponderosa pine - DBHIB = D0 + D1*DBHOB + D2*DBHOB*DBHOB + DBHIB = REAL(D0 + D1*DBHOB + D2*DBHOB*DBHOB) ENDIF DBTBH = DBHOB - DBHIB ELSE @@ -155,7 +155,7 @@ SUBROUTINE BRK_OT(JSP,geosub,DBHOB,DOB,HT2,DBTBH,DIB,dbt) ENDIF C ENDIF - DBT = PY * DBTBH + DBT = REAL(PY * DBTBH) DIB = DOB - DBT @@ -353,28 +353,28 @@ SUBROUTINE SHP_OT(JSP,DBHOB,HTTOT,RFLW,RHFW) c Define geometric parameters c (These outcomes are SINGLE precision) - R1= dexp(U1)/ (1.0d0 + dexp(U1)) - R2= dexp(U2)/ (1.0d0 + dexp(U2)) - R3= dexp(U3)/ (1.0d0 + dexp(U3)) - R4= dexp(U4)/ (1.0d0 + dexp(U4)) + R1= REAL(dexp(U1)/ (1.0d0 + dexp(U1))) + R2= REAL(dexp(U2)/ (1.0d0 + dexp(U2))) + R3= REAL(dexp(U3)/ (1.0d0 + dexp(U3))) + R4= REAL(dexp(U4)/ (1.0d0 + dexp(U4))) IF (U5 .le. 7.0d0) then - R5= 0.5d0 + 0.5d0*dexp(U5)/ (1.0d0 + dexp(U5)) + R5= REAL(0.5d0 + 0.5d0*dexp(U5)/ (1.0d0 + dexp(U5))) else R5=1.0 endif - A3=U6 - RHI1 = dexp(U7) / ( 1.0d0 + dexp(U7) ) + A3=REAL(U6) + RHI1 = REAL(dexp(U7) / ( 1.0d0 + dexp(U7) )) if (RHI1.gt. 0.5 ) RHI1=0.5 - RHLONGI= U9 + RHLONGI= REAL(U9) RHI2 = RHI1 + RHLONGI c RHC = RHI2 + (1.0D0 - RHI2) * dexp(U8)/( 1.0d0 + dexp(U8)) c If (RHC .lt. RHI2 +0.01) then c RHC = MIN( RHI2+0.01, (RHI2+1.0)/2.0 ) c endif - RHC=U8 + RHC=REAL(U8) if (RHC .lt. RHI2+.01) RHC= min( RHI2+.01, (RHI2+1.)/2.0 ) C PUT COEFFICIENTS INTO AN ARRAY FOR EASIER PASSING @@ -474,8 +474,8 @@ FUNCTION COR_OT(JSP,HTTOT,HI,HJ) c both heights are above BH t3=(h1-bh)/(HTTOT-bh) t4=(h2-bh)/(HTTOT-bh) - CORR = exp( q1*(t4-t3) + q2*(t4*t4-t3*t3)/2.0D0 - > +q3*(t4*t4*t4 - t3*t3*t3)/3.0D0) + CORR = REAL(exp( q1*(t4-t3) + q2*(t4*t4-t3*t3)/2.0D0 + > +q3*(t4*t4*t4 - t3*t3*t3)/3.0D0)) GO TO 100 endif @@ -483,8 +483,8 @@ FUNCTION COR_OT(JSP,HTTOT,HI,HJ) c h1 < Bh and h2 > BH t3=(h2-bh)/(HTTOT-bh) T2 = (BH-H1)/BH - CORR = q5*exp( q4*t2 + q1*t3 +q2*t3*t3/2.0d0 - > +q3*t3**3 / 3.0d0 ) + CORR = REAL(q5*exp( q4*t2 + q1*t3 +q2*t3*t3/2.0d0 + > +q3*t3**3 / 3.0d0 )) go to 100 endif @@ -492,7 +492,7 @@ FUNCTION COR_OT(JSP,HTTOT,HI,HJ) c note: t2 < t1 T2 = (BH-H2)/BH T1 = (BH-H1)/BH - CORR=exp( q4* (t1-t2)) + CORR=REAL(exp( q4* (t1-t2))) C100 IF ( abs(CORR) .gt. 1.0 .and. ier_UNIT.ne.0) C 1 write(IER_UNIT,102) JSP, H1,H2, CORR @@ -610,24 +610,24 @@ SUBROUTINE VAR_OT(JSP,DBHOB,HTTOT,H,SE_LNX) JSPR = JSP - 22 - VA00 = V(1, JSPR) - VA01 = V(2, JSPR) - VA02 = V(3, JSPR) - VB00 = V(4, JSPR) - VB01 = V(5, JSPR) - VC0 = V(6, JSPR) + VA00 = REAL(V(1, JSPR)) + VA01 = REAL(V(2, JSPR)) + VA02 = REAL(V(3, JSPR)) + VB00 = REAL(V(4, JSPR)) + VB01 = REAL(V(5, JSPR)) + VC0 = REAL(V(6, JSPR)) - VX1 = V(7,JSPR) - VX2 = V(8,JSPR) - VX3 = V(9,JSPR) - - VA03 = V(10, JSPR) - VE00 = V(11, JSPR) - VE01 = V(12, JSPR) - VE02 = V(13, JSPR) - VF00 = V(14, JSPR) - VF01 = V(15, JSPR) - VG0 = V(16, JSPR) + VX1 = REAL(V(7,JSPR)) + VX2 = REAL(V(8,JSPR)) + VX3 = REAL(V(9,JSPR)) + + VA03 = REAL(V(10, JSPR)) + VE00 = REAL(V(11, JSPR)) + VE01 = REAL(V(12, JSPR)) + VE02 = REAL(V(13, JSPR)) + VF00 = REAL(V(14, JSPR)) + VF01 = REAL(V(15, JSPR)) + VG0 = REAL(V(16, JSPR)) BH = 4.5 @@ -635,10 +635,10 @@ SUBROUTINE VAR_OT(JSP,DBHOB,HTTOT,H,SE_LNX) DRATIO = DBHOB/DMEDIAN LOGHT = log(HTTOT) - VA0 = VA00 + VA01*LOGHT + VA02*DRATIO + VA03*LOGHT*DRATIO + VA0 = REAL(VA00 + VA01*LOGHT + VA02*DRATIO + VA03*LOGHT*DRATIO) VB0 = VB00 + VB01*LOGHT - VE0 = VE00 + VE01*LOGHT + VE02*DRATIO + VE0 = REAL(VE00 + VE01*LOGHT + VE02*DRATIO) VF0 = VF00 + VF01*LOGHT VC = VC0 + VX1*LOGHT @@ -746,22 +746,22 @@ SUBROUTINE SHP_BH(DBHOB,HTTOT,RFLW,RHFW) if (u9.lt. 0.0d0) U9 = 0.0d0 c This code taken from RF_SHP2 from the REG1 program - R1 = dexp(U1) / ( 1.0d0 + dexp(U1) ) - R2 = dexp(U2) / ( 1.0d0 + dexp(U2) ) - R3 = dexp(U3) / ( 1.0d0 + dexp(U3) ) - R4 = dexp(U4) / ( 1.0d0 + dexp(U4) ) - R5 = 0.5 + 0.5*dexp(U5) / ( 1.0d0 + dexp(U5) ) + R1 = REAL(dexp(U1) / ( 1.0d0 + dexp(U1) )) + R2 = REAL(dexp(U2) / ( 1.0d0 + dexp(U2) )) + R3 = REAL(dexp(U3) / ( 1.0d0 + dexp(U3) )) + R4 = REAL(dexp(U4) / ( 1.0d0 + dexp(U4) )) + R5 = REAL(0.5 + 0.5*dexp(U5) / ( 1.0d0 + dexp(U5) )) IF (U5 .gt. 7.0) R5 = 1.0 - a3 = U6 - RHI1 = dexp(U7) / ( 1.0d0 + dexp(U7) ) + a3 = REAL(U6) + RHI1 = REAL(dexp(U7) / ( 1.0d0 + dexp(U7) )) IF (RHI1.GT. 0.5) RHI1=0.5 - RHLONGI = U9 + RHLONGI = REAL(U9) RHI2 = RHI1 + RHLONGI - RHC = U8 + RHC = REAL(U8) IF (RHC.LT.RHI2+0.01) RHC = MIN(RHI2 + 0.01, > (RHI2 + 1.0)/2.0) RHFW(1) = RHI1 @@ -822,8 +822,8 @@ FUNCTION COR_BH(HTTOT,H30,HT2) c both heights are above BH T3=(H1-4.5)/(HTTOT-4.5) T4=(H2-4.5)/(HTTOT-4.5) - COR_BH = exp( Q1 * (T4 - T3) + Q2 * (T4*T4 - T3*T3)/2.0d0 + - > Q3 * (T4*T4*T4 - T3*T3*T3)/3.0d0) + COR_BH = REAL(exp( Q1*(T4 - T3) + Q2*(T4*T4-T3*T3)/2.0d0 + + > Q3 * (T4*T4*T4 - T3*T3*T3)/3.0d0)) IF(COR_BH.GT.0.999) COR_BH = 0.999 RETURN ENDIF @@ -832,8 +832,8 @@ FUNCTION COR_BH(HTTOT,H30,HT2) c h1 < Bh and h2 > BH T3 = (H2 - 4.5)/(HTTOT - 4.5) T2 = (4.5 - H1)/4.5 - COR_BH = Q5 * exp( Q4 * T2 + Q1 * T3 + Q2*T3*T3/2.0d0 + - > Q3*T3*T3*T3 / 3.0d0) + COR_BH = REAL(Q5 * exp( Q4 * T2 + Q1 * T3 + Q2*T3*T3/2.0d0 + + > Q3*T3*T3*T3 / 3.0d0)) IF(COR_BH .GT. 0.999) COR_BH = 0.999 IF(COR_BH .LT.-0.999) COR_BH = -0.999 RETURN @@ -845,7 +845,7 @@ FUNCTION COR_BH(HTTOT,H30,HT2) T1 = (4.5 - H1)/4.5 CORR = exp( Q4 * (T1-T2)) - COR_BH = CORR + COR_BH = REAL(CORR) RETURN END @@ -873,15 +873,15 @@ SUBROUTINE VAR_BH (DBHOB,HTTOT,HUP,SE) c below BH IF (HUP .LT. 4.5) THEN - LVARHAT = -.15512542D+01-.82366251*HUP +.10190777*DBHOB + LVARHAT = REAL(-.15512542D+01-.82366251*HUP+.10190777*DBHOB) VARHAT = exp(LVARHAT) c above breast height ELSEIF (HUP .GT. 4.5) THEN RH = (HUP - 4.5)/(HTTOT - 4.5) - LVARHAT = (-.72335700D+01 + .22333875D+01*LOG(DBHOB)) + + LVARHAT = REAL((-.72335700D+01 + .22333875D+01*LOG(DBHOB)) + > (.25870429D+01-.43950365D-01*LOG(DBHOB)) * - > RH**(-.57411597D+00 + .67914946D+00*log(DBHOB)) + > RH**(-.57411597D+00 + .67914946D+00*log(DBHOB))) VARHAT = exp(LVARHAT) c at breast height ELSE