1001
1002
1005
1007# ifdef DISTRIBUTE
1009# endif
1010
1011
1012
1013 integer, intent(in) :: ng, tile, model, boundary
1014 integer, intent(in) :: edge(4)
1015 integer, intent(in) :: LBij, UBij
1016 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
1017 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
1018 integer, intent(in) :: Nghost
1019 integer, intent(in) :: NHsteps, NVsteps
1020
1021 real(r8), intent(in) :: DTsizeH, DTsizeV
1022
1023# ifdef ASSUMED_SHAPE
1024 real(r8), intent(in) :: pm(LBi:,LBj:)
1025 real(r8), intent(in) :: pn(LBi:,LBj:)
1026 real(r8), intent(in) :: pmon_r(LBi:,LBj:)
1027 real(r8), intent(in) :: pnom_p(LBi:,LBj:)
1028# ifdef MASKING
1029 real(r8), intent(in) :: umask(LBi:,LBj:)
1030 real(r8), intent(in) :: pmask(LBi:,LBj:)
1031# endif
1032 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
1033 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
1034
1035 real(r8), intent(in) :: Kh(LBi:,LBj:)
1036 real(r8), intent(in) :: Kv(LBi:,LBj:,0:)
1037 real(r8), intent(inout) :: ad_A(LBij:,LBk:)
1038# else
1039 real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj)
1040 real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj)
1041 real(r8), intent(in) :: pmon_r(LBi:UBi,LBj:UBj)
1042 real(r8), intent(in) :: pnom_p(LBi:UBi,LBj:UBj)
1043# ifdef MASKING
1044 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
1045 real(r8), intent(in) :: pmask(LBi:UBi,LBj:UBj)
1046# endif
1047 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
1048 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,N(ng))
1049
1050 real(r8), intent(in) :: Kh(LBi:UBi,LBj:UBj)
1051 real(r8), intent(in) :: Kv(LBi:UBi,LBj:UBj,0:UBk)
1052 real(r8), intent(inout) :: ad_A(LBij:UBij,LBk:UBk)
1053# endif
1054
1055
1056
1057 logical, dimension(4) :: Lconvolve
1058
1059 integer :: Nnew, Nold, Nsav, i, j, k, step
1060
1061 real(r8) :: adfac, cff, cff1
1062
1063 real(r8), dimension(LBij:UBij,LBk:UBk,2) :: ad_Awrk
1064
1065 real(r8), dimension(JminS:JmaxS,LBk:UBk) :: ad_FE
1066 real(r8), dimension(IminS:ImaxS,LBk:UBk) :: ad_FX
1067 real(r8), dimension(LBij:UBij) :: Hfac
1068# ifdef VCONVOLUTION
1069# ifndef SPLINES_VCONV
1070 real(r8), dimension(LBij:UBij,0:N(ng)) :: FC
1071# endif
1072# if !defined IMPLICIT_VCONV || defined SPLINES_VCONV
1073 real(r8), dimension(LBij:UBij,N(ng)) :: oHz
1074# endif
1075# if defined IMPLICIT_VCONV || defined SPLINES_VCONV
1076 real(r8), dimension(LBij:UBij,0:N(ng)) :: BC
1077 real(r8), dimension(LBij:UBij,0:N(ng)) :: CF
1078# ifdef SPLINES_VCONV
1079 real(r8), dimension(LBij:UBij,0:N(ng)) :: FC
1080# endif
1081 real(r8), dimension(LBij:UBij,0:N(ng)) :: ad_DC
1082# else
1083 real(r8), dimension(LBij:UBij,0:N(ng)) :: ad_FS
1084# endif
1085# endif
1086
1087# include "set_bounds.h"
1088
1089
1090
1091
1092
1093 ad_awrk(lbij:ubij,lbk:ubk,1:2)=0.0_r8
1094# ifdef VCONVOLUTION
1095# ifdef IMPLICIT_VCONV
1096 ad_dc(lbij:ubij,0:
n(ng))=0.0_r8
1097# else
1098 ad_fs(lbij:ubij,0:
n(ng))=0.0_r8
1099# endif
1100# endif
1101 ad_fe(jmins:jmaxs,lbk:ubk)=0.0_r8
1102 ad_fx(imins:imaxs,lbk:ubk)=0.0_r8
1103
1104
1105
1106
1107
1108
1113
1114
1115
1116 nold=1
1117 nnew=2
1118
1119
1120
1121
1122
1123 IF (lconvolve(boundary)) THEN
1124 cff=dtsizeh*0.25_r8
1125 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1126 i=edge(boundary)
1127 DO j=jstr-1,jend+1
1128 hfac(j)=cff*(pm(i-1,j)+pm(i,j))*(pn(i-1,j)+pn(i,j))
1129# ifdef VCONVOLUTION
1130# ifndef SPLINES_VCONV
1133# ifdef IMPLICIT_VCONV
1134 fc(j,k)=-dtsizev*(kv(i-1,j,k)+kv(i,j,k))/ &
1135 & (z_r(i-1,j,k+1)+z_r(i,j,k+1)- &
1136 & z_r(i-1,j,k )-z_r(i,j,k ))
1137# else
1138 fc(j,k)=dtsizev*(kv(i-1,j,k)+kv(i,j,k))/ &
1139 & (z_r(i-1,j,k+1)+z_r(i,j,k+1)- &
1140 & z_r(i-1,j,k )-z_r(i,j,k ))
1141# endif
1142 END DO
1143 fc(j,0)=0.0_r8
1144# endif
1145# if !defined IMPLICIT_VCONV || defined SPLINES_VCONV
1147 ohz(j,k)=2.0_r8/(hz(i-1,j,k)+hz(i,j,k))
1148 END DO
1149# endif
1150# endif
1151 END DO
1152 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1153 j=edge(boundary)
1154 DO i=istru-1,iend+1
1155 hfac(i)=cff*(pm(i-1,j)+pm(i,j))*(pn(i-1,j)+pn(i,j))
1156# ifdef VCONVOLUTION
1157# ifndef SPLINES_VCONV
1160# ifdef IMPLICIT_VCONV
1161 fc(i,k)=-dtsizev*(kv(i-1,j,k)+kv(i,j,k))/ &
1162 & (z_r(i-1,j,k+1)+z_r(i,j,k+1)- &
1163 & z_r(i-1,j,k )-z_r(i,j,k ))
1164# else
1165 fc(i,k)=dtsizev*(kv(i-1,j,k)+kv(i,j,k))/ &
1166 & (z_r(i-1,j,k+1)+z_r(i,j,k+1)- &
1167 & z_r(i-1,j,k )-z_r(i,j,k ))
1168# endif
1169 END DO
1170 fc(i,0)=0.0_r8
1171# endif
1172# if !defined IMPLICIT_VCONV || defined SPLINES_VCONV
1174 ohz(i,k)=2.0_r8/(hz(i-1,j,k)+hz(i,j,k))
1175 END DO
1176# endif
1177# endif
1178 END DO
1179 END IF
1180 END IF
1181
1182
1183
1184
1185
1186# ifdef DISTRIBUTE
1187
1188
1189
1190
1191
1192
1194 & lbij, ubij, 1,
n(ng), &
1195 & nghost, &
1197 & ad_a)
1198# endif
1199
1200
1201
1202
1204 & lbij, ubij, 1,
n(ng), &
1205 & ad_a)
1206 IF (lconvolve(boundary)) THEN
1207 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1209 DO j=jstr,jend
1210
1211
1212 ad_awrk(j,k,nold)=ad_awrk(j,k,nold)+ &
1213 & ad_a(j,k)
1214 ad_a(j,k)=0.0_r8
1215 END DO
1216 END DO
1217 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1219 DO i=istr,iend
1220
1221
1222 ad_awrk(i,k,nold)=ad_awrk(i,k,nold)+ &
1223 & ad_a(i,k)
1224 ad_a(i,k)=0.0_r8
1225 END DO
1226 END DO
1227 END IF
1228 END IF
1229
1230# ifdef VCONVOLUTION
1231# ifdef IMPLICIT_VCONV
1232# ifdef SPLINES_VCONV
1233
1234
1235
1236
1237
1238
1239 DO step=1,nvsteps
1240
1241
1242
1243 nsav=nnew
1244 nnew=nold
1245 nold=nsav
1246
1247
1248
1249
1250
1251
1252
1253 IF (lconvolve(boundary)) THEN
1254 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1255 i=edge(boundary)
1256 cff1=0.5_r8*(1.0_r8/6.0_r8)
1257 DO j=jstr,jend
1259 fc(j,k)=cff1*(hz(i-1,j,k )+hz(i,j,k ))- &
1260 & dtsizev*kv(i,j,k-1)*ohz(j,k )
1261 cf(j,k)=cff1*(hz(i-1,j,k+1)+hz(i,j,k+1))- &
1262 & dtsizev*kv(i,j,k+1)*ohz(j,k+1)
1263 END DO
1264 cf(j,0)=0.0_r8
1265 END DO
1266 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1267 j=edge(boundary)
1268 cff1=0.5_r8*(1.0_r8/6.0_r8)
1269 DO i=istru,iend
1271 fc(i,k)=cff1*(hz(i-1,j,k )+hz(i,j,k ))- &
1272 & dtsizev*kv(i,j,k-1)*ohz(i,k )
1273 cf(i,k)=cff1*(hz(i-1,j,k+1)+hz(i,j,k+1))- &
1274 & dtsizev*kv(i,j,k+1)*ohz(i,k+1)
1275 END DO
1276 cf(i,0)=0.0_r8
1277 END DO
1278 END IF
1279
1280
1281
1282 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1283 i=edge(boundary)
1284 cff1=0.5_r8*(1.0_r8/3.0_r8)
1286 DO j=jstr,jend
1287 bc(j,k)=cff1*(hz(i-1,j,k )+hz(i,j,k )+ &
1288 & hz(i-1,j,k+1)+hz(i,j,k+1))+ &
1289 & dtsizev*kv(i,j,k)* &
1290 & (ohz(j,k)+ohz(j,k+1))
1291 cff=1.0_r8/(bc(j,k)-fc(j,k)*cf(j,k-1))
1292 cf(j,k)=cff*cf(j,k)
1293 END DO
1294 END DO
1295 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1296 j=edge(boundary)
1297 cff1=0.5_r8*(1.0_r8/3.0_r8)
1299 DO i=istru,iend
1300 bc(i,k)=cff1*(hz(i-1,j,k )+hz(i,j,k )+ &
1301 & hz(i-1,j,k+1)+hz(i,j,k+1))+ &
1302 & dtsizev*kv(i,j,k)* &
1303 & (ohz(i,k)+ohz(i,k+1))
1304 cff=1.0_r8/(bc(i,k)-fc(i,k)*cf(i,k-1))
1305 cf(i,k)=cff*cf(i,k)
1306 END DO
1307 END DO
1308 END IF
1309
1310
1311
1312 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1313 i=edge(boundary)
1315 DO j=jstr,jend
1316
1317
1318
1319
1320 adfac=dtsizev*ohz(j,k)*ad_awrk(j,k,nnew)
1321 ad_dc(j,k-1)=ad_dc(j,k-1)-adfac
1322 ad_dc(j,k )=ad_dc(j,k )+adfac
1323 ad_awrk(j,k,nold)=ad_awrk(j,k,nold)+ &
1324 & ad_awrk(j,k,nnew)
1325 ad_awrk(j,k,nnew)=0.0_r8
1326
1327
1328 ad_dc(j,k)=ad_dc(j,k)*kv(i,j,k)
1329 END DO
1330 END DO
1332 DO j=jstr,jend
1333
1334
1335 ad_dc(j,k+1)=ad_dc(j,k+1)-cf(j,k)*ad_dc(j,k)
1336 END DO
1337 END DO
1338 DO j=jstr,jend
1339
1340
1341 ad_dc(j,
n(ng))=0.0_r8
1342 END DO
1343 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1344 j=edge(boundary)
1346 DO i=istru,iend
1347
1348
1349
1350
1351 adfac=dtsizev*ohz(i,k)*ad_awrk(i,k,nnew)
1352 ad_dc(i,k-1)=ad_dc(i,k-1)-adfac
1353 ad_dc(i,k )=ad_dc(i,k )+adfac
1354 ad_awrk(i,k,nold)=ad_awrk(i,k,nold)+ &
1355 & ad_awrk(i,k,nnew)
1356 ad_awrk(i,k,nnew)=0.0_r8
1357
1358
1359 ad_dc(i,k)=ad_dc(i,k)*kv(i,j,k)
1360 END DO
1361 END DO
1363 DO i=istru,iend
1364
1365
1366 ad_dc(i,k+1)=ad_dc(i,k+1)-cf(i,k)*ad_dc(i,k)
1367 END DO
1368 END DO
1369 DO i=istru,iend
1370
1371
1372 ad_dc(i,
n(ng))=0.0_r8
1373 END DO
1374 END IF
1375
1376
1377
1378 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1379 i=edge(boundary)
1381 DO j=jstr,jend
1382 cff=1.0_r8/(bc(j,k)-fc(j,k)*cf(j,k-1))
1383
1384
1385
1386
1387 adfac=cff*ad_dc(j,k)
1388 ad_awrk(j,k ,nold)=ad_awrk(j,k ,nold)-adfac
1389 ad_awrk(j,k+1,nold)=ad_awrk(j,k+1,nold)+adfac
1390 ad_dc(j,k-1)=ad_dc(j,k-1)-fc(j,k)*adfac
1391 ad_dc(j,k)=0.0_r8
1392 END DO
1393 END DO
1394 DO j=jstr,jend
1395
1396
1397 ad_dc(j,0)=0.0_r8
1398 END DO
1399 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1400 j=edge(boundary)
1402 DO i=istru,iend
1403 cff=1.0_r8/(bc(i,k)-fc(i,k)*cf(i,k-1))
1404
1405
1406
1407
1408 adfac=cff*ad_dc(i,k)
1409 ad_awrk(i,k ,nold)=ad_awrk(i,k ,nold)-adfac
1410 ad_awrk(i,k+1,nold)=ad_awrk(i,k+1,nold)+adfac
1411 ad_dc(i,k-1)=ad_dc(i,k-1)-fc(i,k)*adfac
1412 ad_dc(i,k)=0.0_r8
1413 END DO
1414 END DO
1415 DO i=istru,iend
1416
1417
1418 ad_dc(i,0)=0.0_r8
1419 END DO
1420 END IF
1421 END IF
1422 END DO
1423
1424# else
1425
1426
1427
1428
1429
1430 DO step=1,nvsteps
1431
1432
1433
1434 nsav=nnew
1435 nnew=nold
1436 nold=nsav
1437
1438
1439
1440 IF (lconvolve(boundary)) THEN
1441 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1442 i=edge(boundary)
1444 DO j=jstr,jend
1445 cff=0.5_r8*(hz(i-1,j,k)+hz(i,j,k))
1446 bc(j,k)=cff-fc(j,k)-fc(j,k-1)
1447 END DO
1448 END DO
1449 DO j=jstr,jend
1450 cff=1.0_r8/bc(j,1)
1451 cf(j,1)=cff*fc(j,1)
1452 END DO
1454 DO j=jstr,jend
1455 cff=1.0_r8/(bc(j,k)-fc(j,k-1)*cf(j,k-1))
1456 cf(j,k)=cff*fc(j,k)
1457 END DO
1458 END DO
1459 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1460 j=edge(boundary)
1462 DO i=istru,iend
1463 cff=0.5_r8*(hz(i-1,j,k)+hz(i,j,k))
1464 bc(i,k)=cff-fc(i,k)-fc(i,k-1)
1465 END DO
1466 END DO
1467 DO i=istru,iend
1468 cff=1.0_r8/bc(i,1)
1469 cf(i,1)=cff*fc(i,1)
1470 END DO
1472 DO i=istru,iend
1473 cff=1.0_r8/(bc(i,k)-fc(i,k-1)*cf(i,k-1))
1474 cf(i,k)=cff*fc(i,k)
1475 END DO
1476 END DO
1477 END IF
1478
1479
1480
1481 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1482 i=edge(boundary)
1483
1484
1486 DO j=jstr,jend
1487# ifdef MASKING
1488
1489
1490 ad_awrk(j,k,nnew)=ad_awrk(j,k,nnew)*umask(i,j)
1491# endif
1492
1493
1494 ad_dc(j,k)=ad_dc(j,k)+ &
1495 & ad_awrk(j,k,nnew)
1496 ad_awrk(j,k,nnew)=0.0_r8
1497
1498
1499 ad_dc(j,k+1)=-cf(j,k)*ad_dc(j,k)
1500 END DO
1501 END DO
1502 DO j=jstr,jend
1503# ifdef MASKING
1504
1505
1506 ad_awrk(j,
n(ng),nnew)=ad_awrk(j,
n(ng),nnew)*umask(i,j)
1507# endif
1508
1509
1510 ad_dc(j,
n(ng))=ad_dc(j,
n(ng))+ &
1511 & ad_awrk(j,
n(ng),nnew)
1512 ad_awrk(j,
n(ng),nnew)=0.0_r8
1513
1514
1515
1516
1517
1518 adfac=ad_dc(j,
n(ng))/ &
1520 & fc(j,
n(ng)-1)*cf(j,
n(ng)-1))
1521 ad_dc(j,
n(ng)-1)=ad_dc(j,
n(ng)-1)- &
1522 & fc(j,
n(ng)-1)*adfac
1523 ad_dc(j,
n(ng) )=adfac
1524 END DO
1525 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1526 j=edge(boundary)
1527
1528
1530 DO i=istru,iend
1531# ifdef MASKING
1532
1533
1534 ad_awrk(i,k,nnew)=ad_awrk(i,k,nnew)*umask(i,j)
1535# endif
1536
1537
1538 ad_dc(i,k)=ad_dc(i,k)+ &
1539 & ad_awrk(i,k,nnew)
1540 ad_awrk(i,k,nnew)=0.0_r8
1541
1542
1543 ad_dc(i,k+1)=-cf(i,k)*ad_dc(i,k)
1544 END DO
1545 END DO
1546 DO i=istru,iend
1547# ifdef MASKING
1548
1549
1550 ad_awrk(i,
n(ng),nnew)=ad_awrk(i,
n(ng),nnew)*umask(i,j)
1551# endif
1552
1553
1554 ad_dc(i,
n(ng))=ad_dc(i,
n(ng))+ &
1555 & ad_awrk(i,
n(ng),nnew)
1556 ad_awrk(i,
n(ng),nnew)=0.0_r8
1557
1558
1559
1560
1561
1562 adfac=ad_dc(i,
n(ng))/ &
1564 & fc(i,
n(ng)-1)*cf(i,
n(ng)-1))
1565 ad_dc(i,
n(ng)-1)=ad_dc(i,
n(ng)-1)- &
1566 & fc(i,
n(ng)-1)*adfac
1567 ad_dc(i,
n(ng) )=adfac
1568 END DO
1569 END IF
1570
1571
1572
1573 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1574
1575
1577 DO j=jstr,jend
1578 cff=1.0_r8/(bc(j,k)-fc(j,k-1)*cf(j,k-1))
1579
1580
1581 adfac=cff*ad_dc(j,k)
1582 ad_dc(j,k-1)=ad_dc(j,k-1)-fc(j,k-1)*adfac
1583 ad_dc(j,k )=adfac
1584 END DO
1585 END DO
1586 DO j=jstr,jend
1587 cff=1.0_r8/bc(j,1)
1588
1589
1590 ad_dc(j,1)=cff*ad_dc(j,1)
1591 END DO
1592 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1593
1594
1596 DO i=istru,iend
1597 cff=1.0_r8/(bc(i,k)-fc(i,k-1)*cf(i,k-1))
1598
1599
1600 adfac=cff*ad_dc(i,k)
1601 ad_dc(i,k-1)=ad_dc(i,k-1)-fc(i,k-1)*adfac
1602 ad_dc(i,k )=adfac
1603 END DO
1604 END DO
1605 DO i=istru,iend
1606 cff=1.0_r8/bc(i,1)
1607
1608
1609 ad_dc(i,1)=cff*ad_dc(i,1)
1610 END DO
1611 END IF
1612
1613
1614
1615 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1616 i=edge(boundary)
1618 DO j=jstr,jend
1619 cff=0.5_r8*(hz(i-1,j,k)+hz(i,j,k))
1620
1621
1622 ad_awrk(j,k,nold)=ad_awrk(j,k,nold)+ &
1623 & cff*ad_dc(j,k)
1624 ad_dc(j,k)=0.0_r8
1625 END DO
1626 END DO
1627 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1628 j=edge(boundary)
1630 DO i=istru,iend
1631 cff=0.5_r8*(hz(i-1,j,k)+hz(i,j,k))
1632
1633
1634 ad_awrk(i,k,nold)=ad_awrk(i,k,nold)+ &
1635 & cff*ad_dc(i,k)
1636 ad_dc(i,k)=0.0_r8
1637 END DO
1638 END DO
1639 END IF
1640 END IF
1641 END DO
1642# endif
1643
1644# else
1645
1646
1647
1648
1649
1650 DO step=1,nvsteps
1651
1652
1653
1654 nsav=nnew
1655 nnew=nold
1656 nold=nsav
1657
1658
1659
1660
1661 IF (lconvolve(boundary)) THEN
1662 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1664 DO j=jstr,jend
1665
1666
1667
1668
1669 adfac=ohz(j,k)*ad_awrk(j,k,nnew)
1670 ad_fs(j,k-1)=ad_fs(j,k-1)-adfac
1671 ad_fs(j,k )=ad_fs(j,k )+adfac
1672 ad_awrk(j,k,nold)=ad_awrk(j,k,nold)+ &
1673 & ad_awrk(j,k,nnew)
1674 ad_awrk(j,k,nnew)=0.0_r8
1675 END DO
1676 END DO
1677 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1679 DO i=istru,iend
1680
1681
1682
1683
1684 adfac=ohz(i,k)*ad_awrk(i,k,nnew)
1685 ad_fs(i,k-1)=ad_fs(i,k-1)-adfac
1686 ad_fs(i,k )=ad_fs(i,k )+adfac
1687 ad_awrk(i,k,nold)=ad_awrk(i,k,nold)+ &
1688 & ad_awrk(i,k,nnew)
1689 ad_awrk(i,k,nnew)=0.0_r8
1690 END DO
1691 END DO
1692 END IF
1693
1694
1695
1696
1697 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1698 i=edge(boundary)
1699 DO j=jstr,jend
1700
1701
1702 ad_fs(j,
n(ng))=0.0_r8
1703
1704
1705 ad_fs(j,0)=0.0_r8
1707# ifdef MASKING
1708
1709
1710 ad_fs(j,k)=ad_fs(j,k)*umask(i,j)
1711# endif
1712
1713
1714
1715 adfac=fc(j,k)*ad_fs(j,k)
1716 ad_awrk(j,k ,nold)=ad_awrk(j,k ,nold)-adfac
1717 ad_awrk(j,k+1,nold)=ad_awrk(j,k+1,nold)+adfac
1718 ad_fs(j,k)=0.0_r8
1719 END DO
1720 END DO
1721 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1722 j=edge(boundary)
1723 DO i=istru,iend
1724
1725
1726 ad_fs(i,
n(ng))=0.0_r8
1727
1728
1729 ad_fs(i,0)=0.0_r8
1731# ifdef MASKING
1732
1733
1734 ad_fs(i,k)=ad_fs(i,k)*umask(i,j)
1735# endif
1736
1737
1738
1739 adfac=fc(i,k)*ad_fs(i,k)
1740 ad_awrk(i,k ,nold)=ad_awrk(i,k ,nold)-adfac
1741 ad_awrk(i,k+1,nold)=ad_awrk(i,k+1,nold)+adfac
1742 ad_fs(i,k)=0.0_r8
1743 END DO
1744 END DO
1745 END IF
1746 END IF
1747 END DO
1748# endif
1749# endif
1750
1751
1752
1753
1754
1755 DO step=1,nhsteps
1756
1757
1758
1759 nsav=nnew
1760 nnew=nold
1761 nold=nsav
1762
1763
1764
1765# ifdef DISTRIBUTE
1766
1767
1768
1769
1770
1771
1773 & lbij, ubij, 1,
n(ng), &
1774 & nghost, &
1776 & ad_awrk(:,:,nnew))
1777# endif
1778
1779
1780
1781
1783 & lbij, ubij, 1,
n(ng), &
1784 & ad_awrk(:,:,nnew))
1785
1786
1787
1788 IF (lconvolve(boundary)) THEN
1789 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1791 DO j=jstr,jend
1792
1793
1794
1795
1796 adfac=hfac(j)*ad_awrk(j,k,nnew)
1797 ad_fe(j ,k)=ad_fe(j ,k)-adfac
1798 ad_fe(j+1,k)=ad_fe(j+1,k)+adfac
1799 ad_awrk(j,k,nold)=ad_awrk(j,k,nold)+ &
1800 & ad_awrk(j,k,nnew)
1801 ad_awrk(j,k,nnew)=0.0_r8
1802 END DO
1803 END DO
1804 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1806 DO i=istru,iend
1807
1808
1809
1810
1811 adfac=hfac(i)*ad_awrk(i,k,nnew)
1812 ad_fx(i-1,k)=ad_fx(i-1,k)-adfac
1813 ad_fx(i ,k)=ad_fx(i ,k)+adfac
1814 ad_awrk(i,k,nold)=ad_awrk(i,k,nold)+ &
1815 & ad_awrk(i,k,nnew)
1816 ad_awrk(i,k,nnew)=0.0_r8
1817 END DO
1818 END DO
1819 END IF
1820
1821
1822
1823 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1824 i=edge(boundary)
1826 DO j=jstr,jend+1
1827# ifdef MASKING
1828
1829
1830 ad_fe(j,k)=ad_fe(j,k)*pmask(i,j)
1831# endif
1832
1833
1834
1835
1836
1837
1838 adfac=pnom_p(i,j)* &
1839 & 0.25_r8*(kh(i-1,j )+kh(i,j )+ &
1840 & kh(i-1,j-1)+kh(i,j-1))*ad_fe(j,k)
1841 ad_awrk(j-1,k,nold)=ad_awrk(j-1,k,nold)-adfac
1842 ad_awrk(j ,k,nold)=ad_awrk(j ,k,nold)+adfac
1843 ad_fe(j,k)=0.0_r8
1844 END DO
1845 END DO
1846 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1847 j=edge(boundary)
1849 DO i=istru-1,iend
1850
1851
1852
1853
1854 adfac=pmon_r(i,j)*kh(i,j)*ad_fx(i,k)
1855 ad_awrk(i ,k,nold)=ad_awrk(i ,k,nold)-adfac
1856 ad_awrk(i+1,k,nold)=ad_awrk(i+1,k,nold)+adfac
1857 ad_fx(i,k)=0.0_r8
1858 END DO
1859 END DO
1860 END IF
1861 END IF
1862 END DO
1863
1864
1865
1866
1867
1868 IF (lconvolve(boundary)) THEN
1869 IF ((boundary.eq.
iwest).or.(boundary.eq.
ieast))
THEN
1871 DO j=jstr-1,jend+1
1872
1873
1874 ad_a(j,k)=ad_a(j,k)+ad_awrk(j,k,nold)
1875 ad_awrk(j,k,nold)=0.0_r8
1876 END DO
1877 END DO
1878 ELSE IF ((boundary.eq.
isouth).or.(boundary.eq.
inorth))
THEN
1880 DO i=istru-1,iend+1
1881
1882
1883 ad_a(i,k)=ad_a(i,k)+ad_awrk(i,k,nold)
1884 ad_awrk(i,k,nold)=0.0_r8
1885 END DO
1886 END DO
1887 END IF
1888 END IF
1889# ifdef DISTRIBUTE
1890
1891
1892
1893
1894
1895
1897 & lbij, ubij, 1,
n(ng), &
1898 & nghost, &
1900 & ad_a)
1901# endif
1902
1903
1904
1905
1907 & lbij, ubij, 1,
n(ng), &
1908 & ad_a)
1909
1910 RETURN
subroutine ad_bc_u3d_bry_tile(ng, tile, boundary, lbij, ubij, lbk, ubk, ad_a)