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