Subroutine vom_rootuptake
1480 :
1481 : !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1482 : !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1483 : !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1484 : !*-----root water uptake------------------------------------------------
1485 :
1486 : subroutine vom_rootuptake ()
1487 : use vom_vegwat_mod
1488 : implicit none
1489 :
1490 : if (wlayernew .ge. 1) then
1491 : pos_ult = MIN(pos_slt, wlayer_)
1492 : if (q_md .gt. 0.d0) then
1493 : prootm(1:pos_ult) = (p_mpbar * (-mqt_ + q_mqx) * (750.d0 &
1494 : & - (750.d0 * q_mqx) / (q_md + q_mqx) &
1495 : & + (q_md + q_mqx) / q_mqx)) / (q_md + q_mqx)&
1496 : & - c_hhydrst(1:pos_ult) ! (Out[239])
1497 : else
1498 : ! * set tissue suction to the same as in grasses, if no storage capacity
1499 : prootm(1:pos_ult) = i_prootmg
1500 : endif
1501 :
1502 : ! * soil resistance, (Out[ 241] with svolume=s_delz(1:pos_ult)); derived from (3.32)
1503 : rsoil(1:pos_ult) = SQRT(p_pi / 2.d0) * SQRT((i_rootrad &
1504 : & * s_delz(1:pos_ult)) / rsurft_(1:pos_ult)) &
1505 : & / kunsat_(1:pos_ult)
1506 :
1507 : ! * root water uptake, Chapter 3.3.3.3 (Out[242])
1508 : if (q_md .gt. 0.d0) then
1509 : ruptkt__(1:pos_ult) = (-pcap_(1:pos_ult) + prootm(1:pos_ult))&
1510 : & * rsurft_(1:pos_ult) / (i_rrootm &
1511 : & + rsoil(1:pos_ult))
1512 : ruptkt__(pos_ult+1:s_maxlayer) = 0.d0
1513 : else ! if no storage, uptake happens only when etmt__>0
1514 :
1515 : if (etmt__ .gt. 0.d0) then
1516 : ruptkt__(1:pos_ult) = MAX(0.d0,(-pcap_(1:pos_ult) &
1517 : & + prootm(1:pos_ult)) * rsurft_(1:pos_ult) &
1518 : & / (i_rrootm + rsoil(1:pos_ult)))
1519 : ruptkt__(pos_ult+1:s_maxlayer) = 0.d0
1520 :
1521 : if (SUM(ruptkt__(:)) .gt. 0.d0) then
1522 : if (etmt__ .gt. SUM(ruptkt__(:))) then
1523 : changef = 1.d0
1524 : etmt__ = SUM(ruptkt__(:))
1525 : transpt = etmt__ * 55555.555555555555d0 ! (Out[249]) mol/s=m/s*10^6 g/m/(18g/mol)
1526 : gstomt = transpt / (p_a * vd_h(th_))
1527 : endif
1528 : ! * Setting SUM(ruptkt__)=etmt__ and distributing according to relative uptake:
1529 : ruptkt__(:) = etmt__ * (ruptkt__(:) / (SUM(ruptkt__(:))))
1530 : else
1531 : ruptkt__(:) = 0.d0
1532 : changef = 1.d0
1533 : etmt__ = 0.d0
1534 : transpt = 0.d0
1535 : gstomt = 0.d0
1536 : endif
1537 :
1538 : else
1539 : ruptkt__(:) = 0.d0
1540 : endif
1541 :
1542 : endif
1543 :
1544 : pos_ulg = MIN(pos_slg, wlayer_)
1545 : if (MAXVAL(etmg__(:,:,:)) .gt. 0.d0) then
1546 : ! * root uptake by grasses can not be negative, as storage negligible
1547 : ruptkg__(1:pos_slg) = MAX(0.d0,((-pcap_(1:pos_ulg) &
1548 : & + (i_prootmg - c_hhydrst(1:pos_ulg))) &
1549 : & * rsurfg_(:)) / (i_rrootm + (SQRT(p_pi / 2.d0) &
1550 : & * SQRT(i_rootrad * s_delz(1:pos_ulg) &
1551 : & / rsurfg_(:))) / kunsat_(1:pos_ulg)))
1552 : ruptkg__(pos_ulg+1:s_maxlayer) = 0.d0
1553 : if (SUM(ruptkg__(:)) .gt. 0.d0) then
1554 : where (etmg__(:,:,:) .gt. SUM(ruptkg__(:)))
1555 : rootlim(:,:,:) = 1.d0
1556 : etmg__(:,:,:) = SUM(ruptkg__(:))
1557 : transpg(:,:,:) = etmg__(:,:,:) * 55555.555555555555d0 ! (Out[249]) mol/s=m/s*10^6 g/m/(18g/mol)
1558 : gstomg(:,:,:) = transpg(:,:,:) / (p_a * vd_h(th_))
1559 : end where
1560 : ruptkg__(1:pos_ulg) = etmg__(2,2,2) * (ruptkg__(1:pos_ulg) &
1561 : & / (SUM(ruptkg__(:))))
1562 : else
1563 : ruptkg__(:) = 0.d0
1564 : etmg__(:,:,:) = 0.d0
1565 : transpg(:,:,:) = 0.d0
1566 : gstomg(:,:,:) = 0.d0
1567 : endif
1568 : else
1569 : ruptkg__(:) = 0.d0
1570 : endif
1571 : else
1572 : ruptkg__(:) = 0.d0
1573 : ruptkt__(:) = 0.d0
1574 : etmg__(:,:,:) = 0.d0
1575 : transpg(:,:,:) = 0.d0
1576 : gstomg(:,:,:) = 0.d0
1577 : endif
1578 :
1579 : return
1580 : end subroutine vom_rootuptake