Subroutine vom_gstom
1330 :
1331 : !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1332 : !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1333 : !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1334 : !*-----calculate gstom, et and ass -------------------------------------
1335 :
1336 : subroutine vom_gstom ()
1337 : use vom_vegwat_mod
1338 : implicit none
1339 :
1340 : REAL*8 :: cond1, cond2
1341 : REAL*8 :: cond3(3,3,3)
1342 : REAL*8 :: part1, part2, part3, part4, part5
1343 : REAL*8 :: part6, part7, part8, part9
1344 : INTEGER:: ii
1345 : REAL*8 :: Ma_lg(3)
1346 : REAL*8 :: Ma_lt(3)
1347 :
1348 :
1349 : if (par_h(th_) .gt. 0.d0) then
1350 : ! * adaptation of topt to air temperature during sunlight
1351 : topt_ = topt_ + i_toptf * (tair_h(th_) + 273.d0 - topt_)
1352 :
1353 :
1354 : select case(i_lai_function)
1355 : case(1)
1356 : Ma_lt(:) = 1.0d0
1357 : case(2)
1358 : ! * fraction of absorbed radiation per crown area (Beer-lambert)
1359 : Ma_lt(:) = 1.0d0 - p_E ** (-lai_lt(:) * i_extcoefft )
1360 : end select
1361 :
1362 : ! * calculate electron transport capacity trees
1363 : do ii = 1,3
1364 : jactt(:,ii) = (1.d0 - p_E ** (-(i_alpha * par_h(th_)) &
1365 : & / jmaxt_h(:))) * jmaxt_h(:) * o_cai * Ma_lt(ii) ! (3.23), (Out[311])
1366 : end do
1367 :
1368 : select case(i_lai_function)
1369 : case(1)
1370 : Ma_lg(:) = 1.0d0
1371 : case(2)
1372 : ! * fraction of absorbed radiation per crown area grasses (Beer-lambert)
1373 : Ma_lg(:) = 1.0d0 - p_E ** (-lai_lg(:) * i_extcoeffg)
1374 : end select
1375 :
1376 :
1377 : ! * calculate electron transport capacity grasses
1378 : do ii = 1,3
1379 : jactg(1,:,ii) = (1.d0 - p_E ** (-(i_alpha * par_h(th_)) &
1380 : & / jmaxg_h(:))) * jmaxg_h(:) * pcg_d(1) * Ma_lg(ii) ! (3.23), (Out[311])
1381 : jactg(2,:,ii) = (1.d0 - p_E ** (-(i_alpha * par_h(th_)) &
1382 : & / jmaxg_h(:))) * jmaxg_h(:) * pcg_d(2) * Ma_lg(ii) ! (3.23), (Out[311])
1383 : jactg(3,:,ii) = (1.d0 - p_E ** (-(i_alpha * par_h(th_)) &
1384 : & / jmaxg_h(:))) * jmaxg_h(:) * pcg_d(3) * Ma_lg(ii) ! (3.23), (Out[311])
1385 : end do
1386 :
1387 : cond1 = (2.d0 * p_a * vd_h(th_)) / (ca_h(th_) + 2.d0 * gammastar)
1388 : cond2 = (4.d0 * ca_h(th_) * rlt_h(2,2) + 8.d0 * gammastar &
1389 : & * rlt_h(2,2)) / (ca_h(th_) - gammastar)
1390 : cond3(:,:,:) = (4.d0 * ca_h(th_) * rlg_h(:,:,:) + 8.d0 * gammastar &
1391 : & * rlg_h(:,:,:)) / (ca_h(th_) - gammastar)
1392 :
1393 : if (vd_h(th_) .gt. 0.d0 .and. lambdat_d .gt. cond1 .and. jactt(2,2) .gt. cond2) then
1394 :
1395 : part1 = ca_h(th_) + 2.d0 * gammastar
1396 : part2 = part1 * lambdat_d - p_a * vd_h(th_)
1397 : part3 = p_a * vd_h(th_) * part2
1398 :
1399 : part4 = ca_h(th_) * (jactt(2,2) - 4.d0 * rlt_h(2,2))
1400 : part5 = gammastar * jactt(2,2)
1401 : part6 = gammastar * 8.d0 * rlt_h(2,2)
1402 : part7 = part4 - part5 - part6
1403 :
1404 : part8 = SQRT(part5 * part7 * (part2 - p_a * vd_h(th_)) ** 2.d0 * part3)
1405 : part9 = part7 - 3.d0 * part5 + 1.7320508075688772d0 * part8 / part3
1406 :
1407 : gstomt = 0.25d0 * part9 / part1**2.d0
1408 : gstomt = MAX(0.d0, gstomt) ! (Out[314])
1409 : !check if gstomt remains 0
1410 :
1411 : else
1412 : gstomt = 0.d0
1413 : endif
1414 : transpt = p_a * vd_h(th_) * gstomt ! (3.28) transpiration rate in mol/s
1415 : etmt__ = (transpt * 18.d0) / (10.d0 ** 6.d0) ! transpiration rate in m/s
1416 :
1417 : do ii = 1,3
1418 : where (vd_h(th_) .gt. 0.d0 .and. lambdag_d .gt. cond1 .and. jactg(:,:,ii) .gt. cond3(:,:,ii))
1419 : gstomg(:,:,ii) = MAX(0.d0,(0.25d0 * (p_a * (ca_h(th_) &
1420 : & * (jactg(:,:,ii) - 4.d0 * rlg_h(:,:,ii)) - 4.d0 &
1421 : & * gammastar * (jactg(:,:,ii) + 2.d0 * rlg_h(:,:,ii))) &
1422 : & * vd_h(th_) * (ca_h(th_) * lambdag_d + 2.d0 &
1423 : & * gammastar * lambdag_d - p_a * vd_h(th_)) &
1424 : & + 1.7320508075688772d0 * SQRT(p_a * gammastar &
1425 : & * jactg(:,:,ii) * (ca_h(th_) * (jactg(:,:,ii) - 4.d0 &
1426 : & * rlg_h(:,:,ii)) - gammastar * (jactg(:,:,ii) + 8.d0 &
1427 : & * rlg_h(:,:,ii))) * vd_h(th_) * (ca_h(th_) &
1428 : & * lambdag_d + 2.d0 * gammastar * lambdag_d &
1429 : & - 2.d0 * p_a * vd_h(th_)) ** 2.d0 * (ca_h(th_) &
1430 : & * lambdag_d + 2.d0 * gammastar * lambdag_d - p_a &
1431 : & * vd_h(th_))))) / (p_a * (ca_h(th_) + 2.d0 &
1432 : & * gammastar) ** 2.d0 * vd_h(th_) * (ca_h(th_) &
1433 : & * lambdag_d + 2.d0 * gammastar * lambdag_d &
1434 : & - p_a * vd_h(th_)))) ! (Out[314])
1435 : elsewhere
1436 : gstomg(:,:,ii) = 0.d0
1437 : endwhere
1438 : end do
1439 : transpg(:,:,:) = p_a * vd_h(th_) * gstomg(:,:,:) ! (3.28) transpiration rate in mol/s
1440 : etmg__(:,:,:) = (transpg(:,:,:) * 18.d0) / (10.d0 ** 6.d0) ! transpiration rate in m/s
1441 : else
1442 : jactt(:,:) = 0.d0
1443 : gstomt = 0.d0
1444 : etmt__ = 0.d0
1445 : jactg(:,:,:) = 0.d0
1446 : gstomg(:,:,:) = 0.d0
1447 : etmg__(:,:,:) = 0.d0
1448 : endif
1449 :
1450 :
1451 :
1452 : return
1453 : end subroutine vom_gstom