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