Changeset 5802
- Timestamp:
- 2015-10-16T19:19:43+02:00 (8 years ago)
- Location:
- branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 7 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90
r5779 r5802 200 200 ! ENDIF 201 201 !!gm end 202 202 IF ( lk_vvl ) THEN 203 IF (lwp) PRINT *, 'cons heat : ', kt, zdiff_hc / zvol_tot, zdiff_sc / zvol_tot 204 IF (lwp) PRINT *, 'cons volu : ', kt, zdiff_v2 * 1.e-9 205 ELSE 206 IF (lwp) PRINT *, 'cons heat : ', kt, zdiff_hc1 * 1.e-20 * rau0 * rcp, zdiff_sc1 * 1.e-9 207 IF (lwp) PRINT *, 'cons vol : ', kt, zdiff_v1 * 1.e-9 208 END IF 203 209 IF( lk_vvl ) THEN 204 210 CALL iom_put( 'bgtemper' , zdiff_hc / zvol_tot ) ! Temperature variation (C) -
branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90
r5619 r5802 253 253 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt !: vertical index of the bottom last T- ocean level 254 254 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbku, mbkv !: vertical index of the bottom last U- and W- ocean level 255 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bathy !: ocean depth (meters) 256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior domain T-point mask 255 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bathy !: ocean depth (meters) 256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior domain T-point mask 257 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_h !: internal domain T-point mask (Figure 8.5 NEMO book) 257 258 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bmask !: land/ocean mask of barotropic stream function 258 259 … … 391 392 392 393 ALLOCATE( mbathy(jpi,jpj) , bathy (jpi,jpj) , & 393 & tmask_i(jpi,jpj) , 394 & tmask_i(jpi,jpj) , tmask_h(jpi, jpj), & 394 395 & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , & 395 396 & bmask(jpi,jpj) , & -
branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
r5619 r5802 222 222 ! -------------------- 223 223 tmask_i(:,:) = ssmask(:,:) ! (ISH) tmask_i = 1 even on the ice shelf 224 225 tmask_h(:,:) = 1._wp ! 0 on the halo and 1 elsewhere 224 226 iif = jpreci ! ??? 225 227 iil = nlci - jpreci + 1 … … 227 229 ijl = nlcj - jprecj + 1 228 230 229 tmask_ i( 1 :iif, : ) = 0._wp ! first columns230 tmask_ i(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns)231 tmask_ i( : , 1 :ijf) = 0._wp ! first rows232 tmask_ i( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows)231 tmask_h( 1 :iif, : ) = 0._wp ! first columns 232 tmask_h(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns) 233 tmask_h( : , 1 :ijf) = 0._wp ! first rows 234 tmask_h( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows) 233 235 234 236 ! north fold mask … … 241 243 IF( mjg(nlej) == jpjglo ) THEN ! only half of the nlcj-1 row 242 244 DO ji = iif+1, iil-1 243 tmask_ i(ji,nlej-1) = tmask_i(ji,nlej-1) * tpol(mig(ji))245 tmask_h(ji,nlej-1) = tmask_h(ji,nlej-1) * tpol(mig(ji)) 244 246 END DO 245 247 ENDIF 246 248 ENDIF 249 250 tmask_i(:,:) = tmask_i(:,:) * tmask_h(:,:) 251 247 252 IF( jperio == 5 .OR. jperio == 6 ) THEN ! F-point pivot 248 253 tpol( 1 :jpiglo) = 0._wp -
branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r5779 r5802 1286 1286 1287 1287 ! split last cell if possible (only where water column is 2 cell or less) 1288 !DO jk = jpkm1, 1, -1 1289 ! zmax = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 1290 ! WHERE( gdepw_1d(jk) < bathy(:,:) .AND. bathy(:,:) <= zmax .AND. misfdep + 1 >= mbathy) 1291 ! mbathy(:,:) = jk 1292 ! bathy(:,:) = zmax 1293 ! END WHERE 1294 !END DO 1288 ! if coupled to ice sheet, we do not modify the bathymetry (can be discuss). 1289 IF ( .NOT. ln_iscpl) THEN 1290 DO jk = jpkm1, 1, -1 1291 zmax = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 1292 WHERE( gdepw_1d(jk) < bathy(:,:) .AND. bathy(:,:) <= zmax .AND. misfdep + 1 >= mbathy) 1293 mbathy(:,:) = jk 1294 bathy(:,:) = zmax 1295 END WHERE 1296 END DO 1297 END IF 1295 1298 1296 1299 ! split top cell if possible (only where water column is 2 cell or less) … … 1310 1313 ! test bathy 1311 1314 IF (risfdep(ji,jj) .GT. 1) THEN 1312 zbathydiff =ABS(bathy(ji,jj) - (gdepw_1d(mbathy (ji,jj)+1) + MIN( e3zps_min, e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 1313 zrisfdepdiff=ABS(risfdep(ji,jj) - (gdepw_1d(misfdep(ji,jj) ) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 1315 IF ( .NOT. ln_iscpl ) THEN 1316 zbathydiff =ABS(bathy(ji,jj) - (gdepw_1d(mbathy (ji,jj)+1) & 1317 & + MIN( e3zps_min, e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 1318 zrisfdepdiff=ABS(risfdep(ji,jj) - (gdepw_1d(misfdep(ji,jj) ) & 1319 & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 1314 1320 1315 IF (bathy(ji,jj) .GT. risfdep(ji,jj) .AND. mbathy(ji,jj) .LT. misfdep(ji,jj)) THEN 1316 ! IF (zbathydiff .LE. zrisfdepdiff) THEN 1317 ! bathy(ji,jj) = gdepw_1d(mbathy(ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj)+1)*e3zps_rat ) 1318 ! mbathy(ji,jj)= mbathy(ji,jj) + 1 1319 ! ELSE 1321 IF (bathy(ji,jj) .GT. risfdep(ji,jj) .AND. mbathy(ji,jj) .LT. misfdep(ji,jj)) THEN 1322 IF (zbathydiff .LE. zrisfdepdiff) THEN 1323 bathy(ji,jj) = gdepw_1d(mbathy(ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj)+1)*e3zps_rat ) 1324 mbathy(ji,jj)= mbathy(ji,jj) + 1 1325 ELSE 1326 risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ) 1327 misfdep(ji,jj) = misfdep(ji,jj) - 1 1328 END IF 1329 ENDIF 1330 ELSE 1331 IF (bathy(ji,jj) .GT. risfdep(ji,jj) .AND. mbathy(ji,jj) .LT. misfdep(ji,jj)) THEN 1320 1332 risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ) 1321 1333 misfdep(ji,jj) = misfdep(ji,jj) - 1 1322 !END IF1334 END IF 1323 1335 END IF 1324 1336 END IF … … 1332 1344 ! test bathy 1333 1345 IF( misfdep(ji,jj) == mbathy(ji,jj) .AND. mbathy(ji,jj) .GT. 1) THEN 1334 ! zbathydiff =ABS(bathy(ji,jj) - (gdepw_1d(mbathy (ji,jj)+1) + MIN( e3zps_min,e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 1335 ! zrisfdepdiff=ABS(risfdep(ji,jj) - (gdepw_1d(misfdep(ji,jj) ) - MIN( e3zps_min,e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 1336 ! IF (zbathydiff .LE. zrisfdepdiff) THEN 1337 ! mbathy(ji,jj) = mbathy(ji,jj) + 1 1338 ! bathy(ji,jj) = gdepw_1d(mbathy (ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj) +1)*e3zps_rat ) 1339 ! ELSE 1346 IF ( .NOT. ln_iscpl ) THEN 1347 zbathydiff =ABS(bathy(ji,jj) - ( gdepw_1d(mbathy (ji,jj)+1) & 1348 & + MIN( e3zps_min,e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 1349 zrisfdepdiff=ABS(risfdep(ji,jj) - ( gdepw_1d(misfdep(ji,jj) ) & 1350 & - MIN( e3zps_min,e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 1351 IF (zbathydiff .LE. zrisfdepdiff) THEN 1352 mbathy(ji,jj) = mbathy(ji,jj) + 1 1353 bathy(ji,jj) = gdepw_1d(mbathy (ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj) +1)*e3zps_rat ) 1354 ELSE 1355 misfdep(ji,jj)= misfdep(ji,jj) - 1 1356 risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj))*e3zps_rat ) 1357 END IF 1358 ELSE 1340 1359 misfdep(ji,jj)= misfdep(ji,jj) - 1 1341 risfdep(ji,jj) 1342 !END IF1360 risfdep(ji,jj)= gdepw_1d(misfdep(ji,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj))*e3zps_rat ) 1361 END IF 1343 1362 ENDIF 1344 1363 END DO … … 1349 1368 DO ji = 1, jpim1 1350 1369 IF( misfdep(ji,jj+1) == mbathy(ji,jj) .AND. mbathy(ji,jj) .GT. 1) THEN 1351 ! zbathydiff =ABS(bathy(ji,jj ) - (gdepw_1d(mbathy (ji,jj)+1) + MIN( e3zps_min, e3t_1d(mbathy (ji,jj )+1)*e3zps_rat ))) 1352 ! zrisfdepdiff=ABS(risfdep(ji,jj+1) - (gdepw_1d(misfdep(ji,jj+1)) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1)-1)*e3zps_rat ))) 1353 ! IF (zbathydiff .LE. zrisfdepdiff) THEN 1354 ! mbathy(ji,jj) = mbathy(ji,jj) + 1 1355 ! bathy(ji,jj) = gdepw_1d(mbathy (ji,jj )) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj )+1)*e3zps_rat ) 1356 ! ELSE 1370 IF ( .NOT. ln_iscpl ) THEN 1371 zbathydiff =ABS(bathy(ji,jj ) - ( gdepw_1d(mbathy (ji,jj)+1) & 1372 & + MIN( e3zps_min, e3t_1d(mbathy (ji,jj )+1)*e3zps_rat ))) 1373 zrisfdepdiff=ABS(risfdep(ji,jj+1) - ( gdepw_1d(misfdep(ji,jj+1)) & 1374 & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1)-1)*e3zps_rat ))) 1375 IF (zbathydiff .LE. zrisfdepdiff) THEN 1376 mbathy(ji,jj) = mbathy(ji,jj) + 1 1377 bathy(ji,jj) = gdepw_1d(mbathy (ji,jj )) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj )+1)*e3zps_rat ) 1378 ELSE 1379 misfdep(ji,jj+1) = misfdep(ji,jj+1) - 1 1380 risfdep (ji,jj+1) = gdepw_1d(misfdep(ji,jj+1)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1))*e3zps_rat ) 1381 END IF 1382 ELSE 1357 1383 misfdep(ji,jj+1) = misfdep(ji,jj+1) - 1 1358 1384 risfdep (ji,jj+1) = gdepw_1d(misfdep(ji,jj+1)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1))*e3zps_rat ) 1359 !END IF1385 END IF 1360 1386 ENDIF 1361 1387 END DO … … 1376 1402 DO ji = 1, jpim1 1377 1403 IF( misfdep(ji,jj) == mbathy(ji,jj+1) .AND. mbathy(ji,jj) .GT. 1) THEN 1378 ! zbathydiff =ABS( bathy(ji,jj+1) - (gdepw_1d(mbathy (ji,jj+1)+1) + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ))) 1379 ! zrisfdepdiff=ABS(risfdep(ji,jj ) - (gdepw_1d(misfdep(ji,jj ) ) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj )-1)*e3zps_rat ))) 1380 ! IF (zbathydiff .LE. zrisfdepdiff) THEN 1381 ! mbathy (ji,jj+1) = mbathy(ji,jj+1) + 1 1382 ! bathy (ji,jj+1) = gdepw_1d(mbathy (ji,jj+1) ) + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ) 1383 ! ELSE 1404 IF ( .NOT. ln_iscpl ) THEN 1405 zbathydiff =ABS( bathy(ji,jj+1) - ( gdepw_1d(mbathy (ji,jj+1)+1) & 1406 & + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ))) 1407 zrisfdepdiff=ABS(risfdep(ji,jj ) - ( gdepw_1d(misfdep(ji,jj ) ) & 1408 & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj )-1)*e3zps_rat ))) 1409 IF (zbathydiff .LE. zrisfdepdiff) THEN 1410 mbathy (ji,jj+1) = mbathy(ji,jj+1) + 1 1411 bathy (ji,jj+1) = gdepw_1d(mbathy (ji,jj+1) ) + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ) 1412 ELSE 1413 misfdep(ji,jj) = misfdep(ji,jj) - 1 1414 risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj )+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj ) )*e3zps_rat ) 1415 END IF 1416 ELSE 1384 1417 misfdep(ji,jj) = misfdep(ji,jj) - 1 1385 1418 risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj )+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj ) )*e3zps_rat ) 1386 !END IF1419 END IF 1387 1420 ENDIF 1388 1421 END DO … … 1405 1438 DO ji = 1, jpim1 1406 1439 IF( misfdep(ji+1,jj) == mbathy(ji,jj) .AND. mbathy(ji,jj) .GT. 1) THEN 1407 ! zbathydiff =ABS( bathy(ji ,jj) - (gdepw_1d(mbathy (ji,jj)+1) + MIN( e3zps_min, e3t_1d(mbathy (ji ,jj)+1)*e3zps_rat ))) 1408 ! zrisfdepdiff=ABS(risfdep(ji+1,jj) - (gdepw_1d(misfdep(ji+1,jj)) - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj)-1)*e3zps_rat ))) 1409 ! IF (zbathydiff .LE. zrisfdepdiff) THEN 1410 ! mbathy(ji,jj) = mbathy(ji,jj) + 1 1411 ! bathy(ji,jj) = gdepw_1d(mbathy (ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj) +1)*e3zps_rat ) 1412 ! ELSE 1440 IF ( .NOT. ln_iscpl ) THEN 1441 zbathydiff =ABS( bathy(ji ,jj) - ( gdepw_1d(mbathy (ji,jj)+1) & 1442 & + MIN( e3zps_min, e3t_1d(mbathy (ji ,jj)+1)*e3zps_rat ))) 1443 zrisfdepdiff=ABS(risfdep(ji+1,jj) - ( gdepw_1d(misfdep(ji+1,jj)) & 1444 & - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj)-1)*e3zps_rat ))) 1445 IF (zbathydiff .LE. zrisfdepdiff) THEN 1446 mbathy(ji,jj) = mbathy(ji,jj) + 1 1447 bathy(ji,jj) = gdepw_1d(mbathy (ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj) +1)*e3zps_rat ) 1448 ELSE 1413 1449 misfdep(ji+1,jj)= misfdep(ji+1,jj) - 1 1414 1450 risfdep(ji+1,jj) = gdepw_1d(misfdep(ji+1,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj))*e3zps_rat ) 1415 ! END IF 1451 END IF 1452 ELSE 1453 misfdep(ji+1,jj)= misfdep(ji+1,jj) - 1 1454 risfdep(ji+1,jj) = gdepw_1d(misfdep(ji+1,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj))*e3zps_rat ) 1455 ENDIF 1416 1456 ENDIF 1417 1457 ENDDO … … 1433 1473 DO ji = 1, jpim1 1434 1474 IF( misfdep(ji,jj) == mbathy(ji+1,jj) .AND. mbathy(ji,jj) .GT. 1) THEN 1435 ! zbathydiff =ABS( bathy(ji+1,jj) - (gdepw_1d(mbathy (ji+1,jj)+1) + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj)+1)*e3zps_rat ))) 1436 ! zrisfdepdiff=ABS(risfdep(ji ,jj) - (gdepw_1d(misfdep(ji ,jj) ) - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj)-1)*e3zps_rat ))) 1437 ! IF (zbathydiff .LE. zrisfdepdiff) THEN 1438 ! mbathy(ji+1,jj) = mbathy (ji+1,jj) + 1 1439 ! bathy (ji+1,jj) = gdepw_1d(mbathy (ji+1,jj) ) + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj) +1)*e3zps_rat ) 1440 ! ELSE 1475 IF ( .NOT. ln_iscpl ) THEN 1476 zbathydiff =ABS( bathy(ji+1,jj) - ( gdepw_1d(mbathy (ji+1,jj)+1) & 1477 & + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj)+1)*e3zps_rat ))) 1478 zrisfdepdiff=ABS(risfdep(ji ,jj) - ( gdepw_1d(misfdep(ji ,jj) ) & 1479 & - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj)-1)*e3zps_rat ))) 1480 IF (zbathydiff .LE. zrisfdepdiff) THEN 1481 mbathy(ji+1,jj) = mbathy (ji+1,jj) + 1 1482 bathy (ji+1,jj) = gdepw_1d(mbathy (ji+1,jj) ) + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj) +1)*e3zps_rat ) 1483 ELSE 1484 misfdep(ji,jj) = misfdep(ji ,jj) - 1 1485 risfdep(ji,jj) = gdepw_1d(misfdep(ji ,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj) )*e3zps_rat ) 1486 END IF 1487 ELSE 1441 1488 misfdep(ji,jj) = misfdep(ji ,jj) - 1 1442 1489 risfdep(ji,jj) = gdepw_1d(misfdep(ji ,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj) )*e3zps_rat ) 1443 ! ENDIF1490 ENDIF 1444 1491 ENDIF 1445 1492 ENDDO … … 1530 1577 ibtestim1 = zmisfdep(ji-1,jj ) ; ibtestip1 = zmisfdep(ji+1,jj ) 1531 1578 ibtestjm1 = zmisfdep(ji ,jj-1) ; ibtestjp1 = zmisfdep(ji ,jj+1) 1532 IF( zmisfdep(ji,jj) .GE. mbathy(ji-1,jj ) ) ibtestim1 = jpk !MAX(0, mbathy(ji-1,jj ) - 1)1533 IF( zmisfdep(ji,jj) .GE. mbathy(ji+1,jj ) ) ibtestip1 = jpk !MAX(0, mbathy(ji+1,jj ) - 1)1534 IF( zmisfdep(ji,jj) .GE. mbathy(ji ,jj-1) ) ibtestjm1 = jpk !MAX(0, mbathy(ji ,jj-1) - 1)1535 IF( zmisfdep(ji,jj) .GE. mbathy(ji ,jj+1) ) ibtestjp1 = jpk !MAX(0, mbathy(ji ,jj+1) - 1)1579 IF( zmisfdep(ji,jj) .GE. mbathy(ji-1,jj ) ) ibtestim1 = jpk 1580 IF( zmisfdep(ji,jj) .GE. mbathy(ji+1,jj ) ) ibtestip1 = jpk 1581 IF( zmisfdep(ji,jj) .GE. mbathy(ji ,jj-1) ) ibtestjm1 = jpk 1582 IF( zmisfdep(ji,jj) .GE. mbathy(ji ,jj+1) ) ibtestjp1 = jpk 1536 1583 ibtest=MIN(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) 1537 1584 IF( ibtest == jpk .AND. misfdep(ji,jj) .GE. 2) THEN … … 1562 1609 ibtestim1 = zmbathy(ji-1,jj ) ; ibtestip1 = zmbathy(ji+1,jj ) 1563 1610 ibtestjm1 = zmbathy(ji ,jj-1) ; ibtestjp1 = zmbathy(ji ,jj+1) 1564 IF( zmbathy(ji,jj) .LT. misfdep(ji-1,jj ) ) ibtestim1 = 0 !MIN(jpk-1, misfdep(ji-1,jj ) + 1)1611 IF( zmbathy(ji,jj) .LT. misfdep(ji-1,jj ) ) ibtestim1 = 0 1565 1612 IF( zmbathy(ji,jj) .LT. misfdep(ji+1,jj ) ) ibtestip1 = 0 1566 1613 IF( zmbathy(ji,jj) .LT. misfdep(ji ,jj-1) ) ibtestjm1 = 0 … … 1756 1803 ENDIF 1757 1804 ! ... on ik / ik-1 1758 e3w_0 (ji,jj,ik ) = e3t_0 (ji,jj,ik) !2._wp * (gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik))1805 e3w_0 (ji,jj,ik ) = e3t_0 (ji,jj,ik) 1759 1806 e3t_0 (ji,jj,ik-1) = gdepw_0(ji,jj,ik) - gdepw_1d(ik-1) 1760 1807 ! The next line isn't required and doesn't affect results - included for consistency with bathymetry code -
branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90
r5790 r5802 64 64 REAL(wp):: zjip1_ratio, zjim1_ratio, zjjp1_ratio, zjjm1_ratio 65 65 !! 66 REAL(wp), DIMENSION(:,: ), POINTER :: zde3t 66 REAL(wp), DIMENSION(:,: ), POINTER :: zde3t, zdtem, zdsal 67 67 REAL(wp), DIMENSION(:,: ), POINTER :: zssh0 68 68 REAL(wp), DIMENSION(:,:,: ), POINTER :: ztmp3d … … 74 74 75 75 CALL wrk_alloc(jpi,jpj,jpk, ztmp3d ) 76 CALL wrk_alloc(jpi,jpj, zde3t )76 CALL wrk_alloc(jpi,jpj, zde3t , zdtem, zdsal ) 77 77 CALL wrk_alloc(jpi,jpj, zssh0 ) 78 78 79 79 ! get unbalance (volume heat and salt) 80 80 ! initialisation 81 zde3t (:,:) = 0.0_wp 82 pvol_flx(:,:,: ) = 0.0_wp 83 pts_flx (:,:,:,:) = 0.0_wp 84 85 zsum = glob_sum_full(pvol_flx(:,:,:) ) * rn_fiscpl * rn_rdt 86 IF (lwp) PRINT *, 'total volume correction 0 = ',zsum 87 zsum = glob_sum_full(pts_flx(:,:,:,jp_tem)) * rn_fiscpl * rn_rdt 88 IF (lwp) PRINT *, 'total heat correction 0 = ',zsum 89 zsum = glob_sum_full(pts_flx(:,:,:,jp_sal)) * rn_fiscpl * rn_rdt 90 IF (lwp) PRINT *, 'total salt correction 0 = ',zsum 91 92 ! mask tsn and tsb (should be useless) 93 tsb(:,:,:,jp_tem)=tsb(:,:,:,jp_tem)*ptmask_b(:,:,:); tsn(:,:,:,jp_tem)=tsn(:,:,:,jp_tem)*tmask(:,:,:); 94 tsb(:,:,:,jp_sal)=tsb(:,:,:,jp_sal)*ptmask_b(:,:,:); tsn(:,:,:,jp_sal)=tsn(:,:,:,jp_sal)*tmask(:,:,:); 95 96 ! diagnose non conservation of heat, salt and volume 97 r1_tiscpl = 1._wp / (prdt_iscpl * rn_rdt) 98 zssh0(:,:) = sshn(:,:) * ssmask(:,:) - sshb(:,:) * psmask_b(:,:) 99 IF ( lk_vvl ) zssh0 = 0.0_wp 100 DO jk = 1,jpk-1 101 DO ji = 2,jpi-1 102 DO jj = 2,jpj-1 103 ! volume differences 104 zde3t(ji,jj) = fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) - pe3t_b(ji,jj,jk) * ptmask_b(ji,jj,jk); 105 106 ! shh changes 107 IF ( ptmask_b(ji,jj,jk) == 1 .OR. tmask(ji,jj,jk) == 1 ) THEN 108 zde3t(ji,jj) = zde3t(ji,jj) + zssh0(ji,jj) 109 zssh0(ji,jj) = 0._wp 110 END IF 111 112 ! ocean cell now 113 ! case where we open, enlarge or thin a cell : 114 pvol_flx(ji,jj,jk) = zde3t(ji,jj) * r1_tiscpl 115 pts_flx (ji,jj,jk,jp_sal)= tsn(ji,jj,jk,jp_sal) * zde3t(ji,jj) * r1_tiscpl 116 pts_flx (ji,jj,jk,jp_tem)= tsn(ji,jj,jk,jp_tem) * zde3t(ji,jj) * r1_tiscpl 117 END DO 118 END DO 119 END DO 120 ! glob_sum_full because with glob summ some data can be masked. WARNING the halo have to be set at 0 121 PRINT *, 'test ', narea, SUM(pvol_flx(:,:,:)) * rn_fiscpl * rn_rdt, SUM(pvol_flx(2:jpi-1,2:jpj-1,:)) * rn_fiscpl * rn_rdt 122 zsum = glob_sum_full(pvol_flx(:,:,:) ) * rn_fiscpl * rn_rdt 123 IF (lwp) PRINT *, 'total volume correction 1 = ',zsum 124 zsum = glob_sum_full(pts_flx(:,:,:,jp_tem)) * rn_fiscpl * rn_rdt 125 IF (lwp) PRINT *, 'total heat correction 1 = ',zsum 126 zsum = glob_sum_full(pts_flx(:,:,:,jp_sal)) * rn_fiscpl * rn_rdt 127 IF (lwp) PRINT *, 'total salt correction 1 = ',zsum 128 129 zssh0(:,:) = sshn(:,:) * ssmask(:,:) - sshb(:,:) * psmask_b(:,:) 130 IF ( lk_vvl ) zssh0 = 0.0_wp 131 DO jk = 1,jpk-1 132 DO ji = 2,jpi-1 133 DO jj = 2,jpj-1 134 ! volume differences 135 zde3t(ji,jj) = fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) - pe3t_b(ji,jj,jk) * ptmask_b(ji,jj,jk); 136 137 ! shh changes 138 IF ( ptmask_b(ji,jj,jk) == 1 .OR. tmask(ji,jj,jk) == 1 ) THEN 139 zde3t(ji,jj) = zde3t(ji,jj) + zssh0(ji,jj) 140 zssh0(ji,jj) = 0._wp 141 END IF 142 143 ! ocean cell before and mask cell now 144 IF ( tmask(ji,jj,jk) == 0._wp .AND. ptmask_b(ji,jj,jk) == 1._wp ) THEN 145 ! case where we close a cell and adjacent cell open 146 pvol_flx(ji,jj,jk) = zde3t(ji,jj) * r1_tiscpl 147 pts_flx (ji,jj,jk,jp_sal)= tsb(ji,jj,jk,jp_sal) * zde3t(ji,jj) * r1_tiscpl 148 pts_flx (ji,jj,jk,jp_tem)= tsb(ji,jj,jk,jp_tem) * zde3t(ji,jj) * r1_tiscpl 149 150 jip1=ji+1 ; jim1=ji-1 ; jjp1=jj+1 ; jjm1=jj-1 ; 151 152 zsum = e12t(ji ,jjp1) * tmask(ji ,jjp1,jk) + e12t(ji ,jjm1) * tmask(ji ,jjm1,jk) & 153 & + e12t(jim1,jj ) * tmask(jim1,jj ,jk) + e12t(jip1,jj ) * tmask(jip1,jj ,jk) 154 155 IF ( zsum .NE. 0._wp ) THEN 156 zjip1_ratio = e12t(jip1,jj ) * tmask(jip1,jj ,jk) / zsum 157 zjim1_ratio = e12t(jim1,jj ) * tmask(jim1,jj ,jk) / zsum 158 zjjp1_ratio = e12t(ji ,jjp1) * tmask(ji ,jjp1,jk) / zsum 159 zjjm1_ratio = e12t(ji ,jjm1) * tmask(ji ,jjm1,jk) / zsum 160 161 pvol_flx(ji ,jjp1,jk ) = pvol_flx(ji ,jjp1,jk ) + pvol_flx(ji,jj,jk ) * zjjp1_ratio 162 pvol_flx(ji ,jjm1,jk ) = pvol_flx(ji ,jjm1,jk ) + pvol_flx(ji,jj,jk ) * zjjm1_ratio 163 pvol_flx(jip1,jj ,jk ) = pvol_flx(jip1,jj ,jk ) + pvol_flx(ji,jj,jk ) * zjip1_ratio 164 pvol_flx(jim1,jj ,jk ) = pvol_flx(jim1,jj ,jk ) + pvol_flx(ji,jj,jk ) * zjim1_ratio 165 pts_flx (ji ,jjp1,jk,jp_sal) = pts_flx (ji ,jjp1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjp1_ratio 166 pts_flx (ji ,jjm1,jk,jp_sal) = pts_flx (ji ,jjm1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjm1_ratio 167 pts_flx (jip1,jj ,jk,jp_sal) = pts_flx (jip1,jj ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjip1_ratio 168 pts_flx (jim1,jj ,jk,jp_sal) = pts_flx (jim1,jj ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjim1_ratio 169 pts_flx (ji ,jjp1,jk,jp_tem) = pts_flx (ji ,jjp1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjp1_ratio 170 pts_flx (ji ,jjm1,jk,jp_tem) = pts_flx (ji ,jjm1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjm1_ratio 171 pts_flx (jip1,jj ,jk,jp_tem) = pts_flx (jip1,jj ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjip1_ratio 172 pts_flx (jim1,jj ,jk,jp_tem) = pts_flx (jim1,jj ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjim1_ratio 173 174 ! set to 0 the cell we distributed over neigbourg cells 175 pvol_flx(ji,jj,jk ) = 0._wp 176 pts_flx (ji,jj,jk,jp_sal) = 0._wp 177 pts_flx (ji,jj,jk,jp_tem) = 0._wp 178 179 ELSE IF (zsum .EQ. 0._wp ) THEN 180 ! case where we close a cell and no adjacent cell open 181 ! check if the cell beneath is wet 182 IF ( tmask(ji,jj,jk+1) .EQ. 1._wp ) THEN 183 pvol_flx(ji,jj,jk+1) = pvol_flx(ji,jj,jk+1) + pvol_flx(ji,jj,jk) 184 pts_flx (ji,jj,jk+1,jp_sal)= pts_flx (ji,jj,jk+1,jp_sal) + pts_flx (ji,jj,jk,jp_sal) 185 pts_flx (ji,jj,jk+1,jp_tem)= pts_flx (ji,jj,jk+1,jp_tem) + pts_flx (ji,jj,jk,jp_tem) 186 187 ! set to 0 the cell we distributed over neigbourg cells 188 pvol_flx(ji,jj,jk ) = 0._wp 189 pts_flx (ji,jj,jk,jp_sal) = 0._wp 190 pts_flx (ji,jj,jk,jp_tem) = 0._wp 191 ELSE 192 ! case no adjacent cell on the horizontal and on the vertical 193 PRINT *, 'W A R N I N G iscpl: no adjacent cell on the vertical and horizontal' 194 PRINT *, ' ',mig(ji),' ',mjg(jj),' ',jk 195 PRINT *, ' ',ji,' ',jj,' ',jk,' ',narea 196 PRINT *, ' we are now looking for the closest wet cell on the horizontal ' 197 ! We deal with this points later. 198 END IF 199 END IF 200 END IF 201 END DO 202 END DO 203 END DO 204 205 zsum = glob_sum_full(pvol_flx(:,:,:) ) * rn_fiscpl * rn_rdt 206 IF (lwp) PRINT *, 'total volume correction 2 = ',zsum 207 zsum = glob_sum_full(pts_flx(:,:,:,jp_tem)) * rn_fiscpl * rn_rdt 208 IF (lwp) PRINT *, 'total heat correction 2 = ',zsum 209 zsum = glob_sum_full(pts_flx(:,:,:,jp_sal)) * rn_fiscpl * rn_rdt 210 IF (lwp) PRINT *, 'total salt correction 2 = ',zsum 211 212 ! allocation and initialisation of the list of problematic point 213 ALLOCATE(vnpts(jpnij)) 214 vnpts(:)=0 215 216 ! fill narea location with the number of problematic point 217 DO jk = 1,jpk-1 218 DO ji = 2,jpi-1 219 DO jj = 2,jpj-1 220 IF ( ptmask_b(ji,jj,jk) == 1 .AND. SUM(tmask(ji-1:ji+1,jj,jk)) == 0 & 221 & .AND. SUM(tmask(ji,jj-1:jj+1,jk)) == 0 .AND. tmask(ji,jj,jk+1) == 0 ) THEN 222 vnpts(narea) = vnpts(narea) + 1 223 END IF 224 END DO 225 END DO 226 END DO 227 228 ! build array of total problematic point on each cpu (share to each cpu) 229 CALL mpp_max(vnpts,jpnij) 230 231 ! size of the new variable 232 npts = SUM(vnpts) 233 234 ! allocation of the coordinates, correction, index vector for the problematic points 235 ALLOCATE(ixpts(npts), iypts(npts), izpts(npts), zcorr_vol(npts), zcorr_sal(npts), zcorr_tem(npts), zlon(npts), zlat(npts)) 236 ixpts(:) = -9999 ; iypts(:) = -9999 ; izpts(:) = -9999 ; zlon(:) = -1.0e20 ; zlat(:) = -1.0e20 237 zcorr_vol(:) = 0.0_wp 238 zcorr_sal(:) = 0.0_wp 239 zcorr_tem(:) = 0.0_wp 240 241 ! fill new variable 242 jpts = SUM(vnpts(1:narea-1)) 243 DO jk = 1,jpk-1 244 DO ji = 2,jpi-1 245 DO jj = 2,jpj-1 246 IF ( ptmask_b(ji,jj,jk) == 1 .AND. SUM(tmask(ji-1:ji+1,jj,jk)) == 0 & 247 & .AND. SUM(tmask(ji,jj-1:jj+1,jk)) == 0 .AND. tmask(ji,jj,jk+1) == 0 ) THEN 248 jpts = jpts + 1 ! positioning in the vnpts vector for the area narea 249 PRINT *, 'corrected point ', narea, ji, jj, jk, jpts 250 ixpts(jpts) = ji ; iypts(jpts) = jj ; izpts(jpts) = jk 251 zlon (jpts) = glamt(ji,jj) ; zlat (jpts) = gphit(ji,jj) 252 zcorr_vol(jpts) = pvol_flx(ji,jj,jk) 253 zcorr_sal(jpts) = pts_flx (ji,jj,jk,jp_sal) 254 zcorr_tem(jpts) = pts_flx (ji,jj,jk,jp_tem) 255 ! set flx to 0 (safer) 256 pvol_flx(ji,jj,jk ) = 0.0_wp 257 pts_flx (ji,jj,jk,jp_sal) = 0.0_wp 258 pts_flx (ji,jj,jk,jp_tem) = 0.0_wp 259 PRINT *, zcorr_vol(jpts)*rn_fiscpl*rn_rdt, zcorr_sal(jpts)*rn_fiscpl*rn_rdt, zcorr_tem(jpts)*rn_fiscpl*rn_rdt 260 END IF 261 END DO 262 END DO 263 END DO 264 265 ! build array of total problematic point on each cpu (share to each cpu) 266 CALL mpp_max(zlat ,npts) 267 CALL mpp_max(zlon ,npts) 268 CALL mpp_max(izpts,npts) 269 270 ! put correction term in the closest cell 271 PRINT *, 'corrected point1 ', narea, zlon, zlat, izpts 272 DO jpts = 1,npts 273 CALL dom_ngb(zlon(jpts), zlat(jpts), ixpts(jpts), iypts(jpts),'T', izpts(jpts)) 274 PRINT *, 'corrected point2 ', narea, jpts, ixpts(jpts), iypts(jpts), izpts(jpts) 275 DO jj = mj0(iypts(jpts)),mj1(iypts(jpts)) 276 DO ji = mi0(ixpts(jpts)),mi1(ixpts(jpts)) 277 jk = izpts(jpts) 278 pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk ) + zcorr_vol(jpts) 279 pts_flx (ji,jj,jk,jp_sal) = pts_flx (ji,jj,jk,jp_sal) + zcorr_sal(jpts) 280 pts_flx (ji,jj,jk,jp_tem) = pts_flx (ji,jj,jk,jp_tem) + zcorr_tem(jpts) 281 END DO 282 END DO 283 END DO 284 ! deallocate variables 285 DEALLOCATE(vnpts) 286 DEALLOCATE(ixpts, iypts, izpts, zcorr_vol, zcorr_sal, zcorr_tem, zlon, zlat) 287 288 ! add contribution store on the hallo (lbclnk remove one of the contribution) 289 pvol_flx(:,:,: ) = pvol_flx(:,:,: ) * tmask(:,:,:) 290 pts_flx (:,:,:,jp_tem) = pts_flx (:,:,:,jp_tem) * tmask(:,:,:) 291 pts_flx (:,:,:,jp_sal) = pts_flx (:,:,:,jp_sal) * tmask(:,:,:) 292 293 CALL lbc_sum(pvol_flx(:,:,: ),'T',1.) 294 CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 295 CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 296 297 ! CHECK vol !!!!!!!!! warning tmask_i wrong if deals with before value, so glob_sum wrong for before value!!!! 298 zsumn = glob_sum ( fse3t_n(:,:,:) * tmask (:,:,:)) - glob_sum(pvol_flx(:,:,:)) * rn_fiscpl * rn_rdt 299 ztmp3d(:,:,:) = 0.0 300 ztmp3d(2:jpi-1,2:jpj-1,:) = pe3t_b(2:jpi-1,2:jpj-1,:) * ptmask_b(2:jpi-1,2:jpj-1,:) 301 zsumb = glob_sum_full(ztmp3d) 302 zsum = glob_sum ( pvol_flx(:,:,:) * rn_fiscpl * rn_rdt) 303 IF (lwp) PRINT *, 'CHECK vol = ',zsumn, zsumb, zsumn - zsumb, zsum 304 ! CHECK salt 305 zsumn = glob_sum( tsn(:,:,:,jp_sal) * fse3t_n(:,:,:) * tmask (:,:,:)) - glob_sum(pts_flx(:,:,:,jp_sal)) * rn_fiscpl * rn_rdt 306 zsumb = glob_sum( tsb(:,:,:,jp_sal) * pe3t_b(:,:,:) * ptmask_b(:,:,:)) 307 zsum = glob_sum( pts_flx(:,:,:,jp_sal)*rn_fiscpl * rn_rdt) 308 IF (lwp) PRINT *, 'CHECK salt = ',zsumn, zsumb, zsumn - zsumb, zsum 309 ! CHECK heat 310 zsumn = glob_sum( tsn(:,:,:,jp_tem) * fse3t_n(:,:,:) * tmask (:,:,:)) - glob_sum(pts_flx(:,:,:,jp_tem)) * rn_fiscpl * rn_rdt 311 zsumb = glob_sum( tsb(:,:,:,jp_tem) * pe3t_b(:,:,:) * ptmask_b(:,:,:)) 312 zsum = glob_sum( pts_flx(:,:,:,jp_tem)*rn_fiscpl * rn_rdt) 313 IF (lwp) PRINT *, 'CHECK heat = ',zsumn, zsumb, zsumn - zsumb, zsum 314 !! 315 CALL wrk_dealloc(jpi,jpj,jpk, ztmp3d ) 316 CALL wrk_dealloc(jpi,jpj, zde3t ) 317 CALL wrk_dealloc(jpi,jpj, zssh0 ) 81 zde3t (:,:) = 0.0_wp 82 pvol_flx(:,:,: ) = 0.0_wp 83 pts_flx (:,:,:,:) = 0.0_wp 84 85 ! mask tsn and tsb (should be useless) 86 tsb(:,:,:,jp_tem)=tsb(:,:,:,jp_tem)*ptmask_b(:,:,:); tsn(:,:,:,jp_tem)=tsn(:,:,:,jp_tem)*tmask(:,:,:); 87 tsb(:,:,:,jp_sal)=tsb(:,:,:,jp_sal)*ptmask_b(:,:,:); tsn(:,:,:,jp_sal)=tsn(:,:,:,jp_sal)*tmask(:,:,:); 88 89 ! diagnose non conservation of heat, salt and volume 90 r1_tiscpl = 1._wp / (prdt_iscpl * rn_rdt) 91 92 zssh0(:,:) = sshn(:,:) * ssmask(:,:) - sshb(:,:) * psmask_b(:,:) 93 IF ( lk_vvl ) zssh0 = 0.0_wp ! already include in the levels by definition 94 95 DO jk = 1,jpk-1 96 DO ji = 2,jpi-1 97 DO jj = 2,jpj-1 98 IF (tmask_h(ji,jj) == 1._wp) THEN 99 100 ! volume differences 101 zde3t(ji,jj) = fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) - pe3t_b(ji,jj,jk) * ptmask_b(ji,jj,jk) 102 103 ! heat diff 104 zdtem(ji,jj) = tsn(ji,jj,jk,jp_tem) * fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) & 105 - tsb(ji,jj,jk,jp_tem) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk) 106 ! salt diff 107 zdsal(ji,jj) = tsn(ji,jj,jk,jp_sal) * fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) & 108 - tsb(ji,jj,jk,jp_sal) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk) 109 110 ! shh changes 111 IF ( ptmask_b(ji,jj,jk) == 1 .OR. tmask(ji,jj,jk) == 1 ) THEN 112 zde3t(ji,jj) = zde3t(ji,jj) + zssh0(ji,jj) 113 zssh0(ji,jj) = 0._wp 114 END IF 115 116 ! volume, heat and salt differences in each cell 117 pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk) + zde3t(ji,jj) * r1_tiscpl 118 pts_flx (ji,jj,jk,jp_sal)= pts_flx (ji,jj,jk,jp_sal) + zdsal(ji,jj) * r1_tiscpl 119 pts_flx (ji,jj,jk,jp_tem)= pts_flx (ji,jj,jk,jp_tem) + zdtem(ji,jj) * r1_tiscpl 120 121 IF ( tmask(ji,jj,jk) == 0._wp .AND. ptmask_b(ji,jj,jk) == 1._wp ) THEN 122 ! case where we close a cell: check if the neighbour cells are wet 123 124 jip1=ji+1 ; jim1=ji-1 ; jjp1=jj+1 ; jjm1=jj-1 ; 125 126 zsum = e12t(ji ,jjp1) * tmask(ji ,jjp1,jk) + e12t(ji ,jjm1) * tmask(ji ,jjm1,jk) & 127 & + e12t(jim1,jj ) * tmask(jim1,jj ,jk) + e12t(jip1,jj ) * tmask(jip1,jj ,jk) 128 129 IF ( zsum .NE. 0._wp ) THEN 130 zjip1_ratio = e12t(jip1,jj ) * tmask(jip1,jj ,jk) / zsum 131 zjim1_ratio = e12t(jim1,jj ) * tmask(jim1,jj ,jk) / zsum 132 zjjp1_ratio = e12t(ji ,jjp1) * tmask(ji ,jjp1,jk) / zsum 133 zjjm1_ratio = e12t(ji ,jjm1) * tmask(ji ,jjm1,jk) / zsum 134 135 pvol_flx(ji ,jjp1,jk ) = pvol_flx(ji ,jjp1,jk ) + pvol_flx(ji,jj,jk ) * zjjp1_ratio 136 pvol_flx(ji ,jjm1,jk ) = pvol_flx(ji ,jjm1,jk ) + pvol_flx(ji,jj,jk ) * zjjm1_ratio 137 pvol_flx(jip1,jj ,jk ) = pvol_flx(jip1,jj ,jk ) + pvol_flx(ji,jj,jk ) * zjip1_ratio 138 pvol_flx(jim1,jj ,jk ) = pvol_flx(jim1,jj ,jk ) + pvol_flx(ji,jj,jk ) * zjim1_ratio 139 pts_flx (ji ,jjp1,jk,jp_sal) = pts_flx (ji ,jjp1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjp1_ratio 140 pts_flx (ji ,jjm1,jk,jp_sal) = pts_flx (ji ,jjm1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjm1_ratio 141 pts_flx (jip1,jj ,jk,jp_sal) = pts_flx (jip1,jj ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjip1_ratio 142 pts_flx (jim1,jj ,jk,jp_sal) = pts_flx (jim1,jj ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjim1_ratio 143 pts_flx (ji ,jjp1,jk,jp_tem) = pts_flx (ji ,jjp1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjp1_ratio 144 pts_flx (ji ,jjm1,jk,jp_tem) = pts_flx (ji ,jjm1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjm1_ratio 145 pts_flx (jip1,jj ,jk,jp_tem) = pts_flx (jip1,jj ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjip1_ratio 146 pts_flx (jim1,jj ,jk,jp_tem) = pts_flx (jim1,jj ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjim1_ratio 147 148 ! set to 0 the cell we distributed over neigbourg cells 149 pvol_flx(ji,jj,jk ) = 0._wp 150 pts_flx (ji,jj,jk,jp_sal) = 0._wp 151 pts_flx (ji,jj,jk,jp_tem) = 0._wp 152 153 ELSE IF (zsum .EQ. 0._wp ) THEN 154 ! case where we close a cell and no adjacent cell open 155 ! check if the cell beneath is wet 156 IF ( tmask(ji,jj,jk+1) .EQ. 1._wp ) THEN 157 pvol_flx(ji,jj,jk+1) = pvol_flx(ji,jj,jk+1) + pvol_flx(ji,jj,jk) 158 pts_flx (ji,jj,jk+1,jp_sal)= pts_flx (ji,jj,jk+1,jp_sal) + pts_flx (ji,jj,jk,jp_sal) 159 pts_flx (ji,jj,jk+1,jp_tem)= pts_flx (ji,jj,jk+1,jp_tem) + pts_flx (ji,jj,jk,jp_tem) 160 161 ! set to 0 the cell we distributed over neigbourg cells 162 pvol_flx(ji,jj,jk ) = 0._wp 163 pts_flx (ji,jj,jk,jp_sal) = 0._wp 164 pts_flx (ji,jj,jk,jp_tem) = 0._wp 165 ELSE 166 ! case no adjacent cell on the horizontal and on the vertical 167 PRINT *, 'W A R N I N G iscpl: no adjacent cell on the vertical and horizontal' 168 PRINT *, ' ',mig(ji),' ',mjg(jj),' ',jk 169 PRINT *, ' ',ji,' ',jj,' ',jk,' ',narea 170 PRINT *, ' we are now looking for the closest wet cell on the horizontal ' 171 ! We deal with this points later. 172 END IF 173 END IF 174 END IF 175 END IF 176 END DO 177 END DO 178 END DO 179 180 CALL lbc_sum(pvol_flx(:,:,: ),'T',1.) 181 CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 182 CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 183 184 zsum = glob_sum_full(pvol_flx(:,:,:) ) * rn_fiscpl * rn_rdt 185 IF (lwp) PRINT *, 'total volume correction 21 = ',zsum 186 zsum = glob_sum_full(pts_flx(:,:,:,jp_tem)) * rn_fiscpl * rn_rdt 187 IF (lwp) PRINT *, 'total heat correction 21 = ',zsum 188 zsum = glob_sum_full(pts_flx(:,:,:,jp_sal)) * rn_fiscpl * rn_rdt 189 IF (lwp) PRINT *, 'total salt correction 21 = ',zsum 190 191 ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point 192 ! allocation and initialisation of the list of problematic point 193 ALLOCATE(vnpts(jpnij)) 194 vnpts(:)=0 195 196 ! fill narea location with the number of problematic point 197 DO jk = 1,jpk-1 198 DO ji = 2,jpi-1 199 DO jj = 2,jpj-1 200 IF ( ptmask_b(ji,jj,jk) == 1 .AND. SUM(tmask(ji-1:ji+1,jj,jk)) == 0 & 201 & .AND. SUM(tmask(ji,jj-1:jj+1,jk)) == 0 .AND. tmask(ji,jj,jk+1) == 0 & 202 & .AND. tmask_h(ji,jj) == 1._wp ) THEN 203 vnpts(narea) = vnpts(narea) + 1 204 END IF 205 END DO 206 END DO 207 END DO 208 209 ! build array of total problematic point on each cpu (share to each cpu) 210 CALL mpp_max(vnpts,jpnij) 211 212 ! size of the new variable 213 npts = SUM(vnpts) 214 215 ! allocation of the coordinates, correction, index vector for the problematic points 216 ALLOCATE(ixpts(npts), iypts(npts), izpts(npts), zcorr_vol(npts), zcorr_sal(npts), zcorr_tem(npts), zlon(npts), zlat(npts)) 217 ixpts(:) = -9999 ; iypts(:) = -9999 ; izpts(:) = -9999 ; zlon(:) = -1.0e20 ; zlat(:) = -1.0e20 218 zcorr_vol(:) = 0.0_wp 219 zcorr_sal(:) = 0.0_wp 220 zcorr_tem(:) = 0.0_wp 221 222 ! fill new variable 223 jpts = SUM(vnpts(1:narea-1)) 224 DO jk = 1,jpk-1 225 DO ji = 2,jpi-1 226 DO jj = 2,jpj-1 227 IF ( ptmask_b(ji,jj,jk) == 1 .AND. SUM(tmask(ji-1:ji+1,jj,jk)) == 0 & 228 & .AND. SUM(tmask(ji,jj-1:jj+1,jk)) == 0 .AND. tmask(ji,jj,jk+1) == 0 & 229 & .AND. tmask_h(ji,jj) == 1 ) THEN 230 jpts = jpts + 1 ! positioning in the vnpts vector for the area narea 231 PRINT *, 'corrected point ', narea, ji, jj, jk, jpts 232 ixpts(jpts) = ji ; iypts(jpts) = jj ; izpts(jpts) = jk 233 zlon (jpts) = glamt(ji,jj) ; zlat (jpts) = gphit(ji,jj) 234 zcorr_vol(jpts) = pvol_flx(ji,jj,jk) 235 zcorr_sal(jpts) = pts_flx (ji,jj,jk,jp_sal) 236 zcorr_tem(jpts) = pts_flx (ji,jj,jk,jp_tem) 237 ! set flx to 0 (safer) 238 pvol_flx(ji,jj,jk ) = 0.0_wp 239 pts_flx (ji,jj,jk,jp_sal) = 0.0_wp 240 pts_flx (ji,jj,jk,jp_tem) = 0.0_wp 241 PRINT *, zcorr_vol(jpts)*rn_fiscpl*rn_rdt, zcorr_sal(jpts)*rn_fiscpl*rn_rdt, zcorr_tem(jpts)*rn_fiscpl*rn_rdt 242 END IF 243 END DO 244 END DO 245 END DO 246 247 ! build array of total problematic point on each cpu (share to each cpu) 248 CALL mpp_max(zlat ,npts) 249 CALL mpp_max(zlon ,npts) 250 CALL mpp_max(izpts,npts) 251 252 ! put correction term in the closest cell 253 PRINT *, 'corrected point1 ', narea, zlon, zlat, izpts 254 DO jpts = 1,npts 255 CALL dom_ngb(zlon(jpts), zlat(jpts), ixpts(jpts), iypts(jpts),'T', izpts(jpts)) 256 PRINT *, 'corrected point2 ', narea, jpts, ixpts(jpts), iypts(jpts), izpts(jpts) 257 DO jj = mj0(iypts(jpts)),mj1(iypts(jpts)) 258 DO ji = mi0(ixpts(jpts)),mi1(ixpts(jpts)) 259 jk = izpts(jpts) 260 pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk ) + zcorr_vol(jpts) 261 pts_flx (ji,jj,jk,jp_sal) = pts_flx (ji,jj,jk,jp_sal) + zcorr_sal(jpts) 262 pts_flx (ji,jj,jk,jp_tem) = pts_flx (ji,jj,jk,jp_tem) + zcorr_tem(jpts) 263 END DO 264 END DO 265 END DO 266 ! deallocate variables 267 DEALLOCATE(vnpts) 268 DEALLOCATE(ixpts, iypts, izpts, zcorr_vol, zcorr_sal, zcorr_tem, zlon, zlat) 269 270 ! add contribution store on the hallo (lbclnk remove one of the contribution) 271 pvol_flx(:,:,: ) = pvol_flx(:,:,: ) * tmask(:,:,:) 272 pts_flx (:,:,:,jp_sal) = pts_flx (:,:,:,jp_sal) * tmask(:,:,:) 273 pts_flx (:,:,:,jp_tem) = pts_flx (:,:,:,jp_tem) * tmask(:,:,:) 274 275 CALL lbc_sum(pvol_flx(:,:,: ),'T',1.) 276 CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 277 CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 278 279 ! CHECK vol !!!!!!!!! warning tmask_i wrong if deals with before value, so glob_sum wrong for before value!!!! 280 zsum = glob_sum_full( pvol_flx(:,:,:) ) 281 IF (lwp) PRINT *, 'CHECK vol = ',zsum 282 ! CHECK salt 283 zsum = glob_sum( pts_flx(:,:,:,jp_sal) ) 284 IF (lwp) PRINT *, 'CHECK salt = ',zsum 285 ! CHECK heat 286 zsum = glob_sum( pts_flx(:,:,:,jp_tem) ) 287 IF (lwp) PRINT *, 'CHECK heat = ',zsum 288 !! 289 CALL wrk_dealloc(jpi,jpj,jpk, ztmp3d ) 290 CALL wrk_dealloc(jpi,jpj, zde3t ) 291 CALL wrk_dealloc(jpi,jpj, zssh0 ) 318 292 END SUBROUTINE iscpl_cons 319 293 -
branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/DOM/iscplrst.F90
r5790 r5802 59 59 CHARACTER(20) :: cfile 60 60 61 CALL wrk_alloc(jpi,jpj,jpk, ztmask_b, zumask_b, zvmask_b) ! need this new variables for evoving isf cavity62 CALL wrk_alloc(jpi,jpj,jpk, ze3t_b , ze3u_b , ze3v_b ) ! need of this variables for interpolation)61 CALL wrk_alloc(jpi,jpj,jpk, ztmask_b, zumask_b, zvmask_b) ! mask before 62 CALL wrk_alloc(jpi,jpj,jpk, ze3t_b , ze3u_b , ze3v_b ) ! e3 before 63 63 CALL wrk_alloc(jpi,jpj,jpk, zdepw_b ) 64 64 CALL wrk_alloc(jpi,jpj, zsmask_b ) … … 105 105 CALL wrk_dealloc(jpi,jpj,jpk, zdepw_b ) 106 106 CALL wrk_dealloc(jpi,jpj, zsmask_b ) 107 108 neuler = 0 ! Euler restart (neuler=0) 109 110 tsb (:,:,:,:) = tsn (:,:,:,:) ! all before fields set to now values 111 ub (:,:,:) = un (:,:,:) 112 vb (:,:,:) = vn (:,:,:) 113 rotb (:,:,:) = rotn (:,:,:) 114 hdivb (:,:,:) = hdivn (:,:,:) 115 fse3t_b(:,:,:) = fse3t_n(:,:,:) 116 sshb (:,:) = sshn (:,:) 107 108 !! next step is an euler time step 109 neuler = 0 110 !! set _b and _n variables equal 111 tsb (:,:,:,:) = tsn (:,:,:,:) 112 ub (:,:,: ) = un (:,:,: ) 113 vb (:,:,: ) = vn (:,:,: ) 114 sshb(:,: ) = sshn(:,:) 115 !! set _b and _n vertical scale factor equal 116 fse3t_b (:,:,:) = fse3t_n (:,:,:) 117 fse3u_b (:,:,:) = fse3u_n (:,:,:) 118 fse3v_b (:,:,:) = fse3v_n (:,:,:) 119 IF ( lk_vvl ) THEN 120 fse3uw_b(:,:,:) = fse3uw_n(:,:,:) 121 fse3vw_b(:,:,:) = fse3vw_n(:,:,:) 122 fsdept_b(:,:,:) = fsdept_n(:,:,:) 123 fsdepw_b(:,:,:) = fsdepw_n(:,:,:) 124 hu_b (:,:) = hu(:,:) 125 hv_b (:,:) = hv(:,:) 126 hur_b(:,:) = hur(:,:) 127 hvr_b(:,:) = hvr(:,:) 128 END IF 117 129 ! 118 130 END SUBROUTINE iscpl_stp … … 166 178 END DO 167 179 168 ! compute ssh169 zsmask0(:,:) = psmask_b(:,:)170 zsmask1(:,:) = psmask_b(:,:)171 172 180 ! compute new ssh if we open a full water column (average of the closest neigbourgs) 173 181 sshb (:,:)=sshn(:,:) 174 182 zssh0(:,:)=sshn(:,:) 183 zsmask0(:,:) = psmask_b(:,:) 184 zsmask1(:,:) = psmask_b(:,:) 175 185 DO iz = 1,10 ! need to be tuned (configuration dependent) 176 186 zdsmask(:,:) = ssmask(:,:)-zsmask0(:,:) … … 198 208 199 209 !============================================================================= 200 ! WARNING we cannot used glob_sum for before time variable (because glob_sum use tmask_i). Need to mask the halo and glob_sum_full201 ztmp3d(:,:,:) = 0.0202 ztmp3d(2:jpi-1,2:jpj-1,:) = fse3t_n(2:jpi-1,2:jpj-1,:) * tmask(2:jpi-1,2:jpj-1,:) &203 & - pe3t_b(2:jpi-1,2:jpj-1,:) * ptmask_b(2:jpi-1,2:jpj-1,:)204 zsum = glob_sum_full(ztmp3d)205 IF (lwp) PRINT *, 'total volume correction 00 = ',zsum206 210 IF ( lk_vvl ) THEN 207 211 ! compute fse3t_n 208 212 DO jk = 1,jpk 209 fse3t_n(:,:,jk) = e3t_0(:,:,jk) * ( 1 + sshn(:,:) / ( ht_0(:,:) + 1. - ssmask(:,:) ) * tmask(:,:,jk) ) 210 END DO 211 ztmp3d(:,:,:) = 0.0 212 ztmp3d(2:jpi-1,2:jpj-1,:) = fse3t_n(2:jpi-1,2:jpj-1,:) * tmask(2:jpi-1,2:jpj-1,:) & 213 & - pe3t_b(2:jpi-1,2:jpj-1,:) * ptmask_b(2:jpi-1,2:jpj-1,:) 214 zsum = glob_sum_full(ztmp3d) 215 IF (lwp) PRINT *, 'total volume correction 01 = ',zsum 213 fse3t_n(:,:,jk) = e3t_0(:,:,jk) * ( 1._wp + sshn(:,:) / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) ) 214 END DO 216 215 217 216 ! compute fse3u/v ... (call interpolation vvl) … … 269 268 270 269 END IF 271 ztmp3d(:,:,:) = 0.0272 ztmp3d(2:jpi-1,2:jpj-1,:) = fse3t_n(2:jpi-1,2:jpj-1,:) * tmask(2:jpi-1,2:jpj-1,:) &273 & - pe3t_b(2:jpi-1,2:jpj-1,:) * ptmask_b(2:jpi-1,2:jpj-1,:)274 zsum = glob_sum_full(ztmp3d)275 IF (lwp) PRINT *, 'total volume correction 02 = ',zsum276 270 277 271 !============================================================================= … … 289 283 END DO 290 284 END DO 285 291 286 ! compute new velocity if we close a cell (check barotropic velocity and change velocity over the water column) 292 287 ! compute barotropic velocity now and after … … 299 294 ztrp(:,:,:) = vn(:,:,:)*fse3v_n(:,:,:); 300 295 zbvn(:,:) = SUM(ztrp,DIM=3) 296 301 297 ! Already know ???????? 302 298 hu1=0.0_wp ; … … 391 387 tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * tmask(:,:,:) 392 388 393 ! CHECK heat 394 zsumn = glob_sum( tsn(:,:,:,jp_tem) * fse3t_n(:,:,:) * zwmaskb(:,:,:) * zwmaskn(:,:,:)) 395 zsumb = glob_sum( tsb(:,:,:,jp_tem) * pe3t_b(:,:,:) * zwmaskb(:,:,:) * zwmaskn(:,:,:)) 396 IF (lwp) PRINT *, 'CHECK tsn = ',zsumn, zsumb 397 398 ! compute new T/S (interpolation) because of vvl 399 IF ( lk_vvl .AND. .FALSE. ) THEN 400 !IF ( lk_vvl ) THEN 389 ! compute new T/S (interpolation) if vvl only for common wet cell in before and after wmask 390 IF ( lk_vvl ) THEN 401 391 DO jk = 2,jpk-1 402 392 DO jj = 1,jpj … … 432 422 END IF 433 423 434 ! CHECK heat 435 ztmp3d(:,:,:) = 0.0 436 ztmp3d(2:jpi-1,2:jpj-1,:) = fse3t_n(2:jpi-1,2:jpj-1,:) * tmask(2:jpi-1,2:jpj-1,:) & 437 & - pe3t_b(2:jpi-1,2:jpj-1,:) * ptmask_b(2:jpi-1,2:jpj-1,:) 438 zsum = glob_sum_full(ztmp3d) 439 IF (lwp) PRINT *, 'total volume correction 03 = ',zsum 440 424 ! Special value for closed pool and set the mask to 0 to run 441 425 WHERE (tmask(:,:,:) == 1.0 .AND. tsn(:,:,:,2) == 0._wp) 442 426 tsn(:,:,:,2)= -99._wp … … 453 437 ! compute new tn and sn if we close cell 454 438 ! nothing to do 455 456 !! next step is an euler time step 457 neuler = 0 458 !! set _b and _n variables equal 459 tsb (:,:,:,:)=tsn (:,:,:,:) 460 ub (:,:,: )=un (:,:,: ) 461 vb (:,:,: )=vn (:,:,: ) 462 sshb(:,: )=sshn(:,:) 463 !! set _b and _n vertical scale factor equal 464 fse3t_b (:,:,:)=fse3t_n (:,:,:) 465 fse3u_b (:,:,:)=fse3u_n (:,:,:) 466 fse3v_b (:,:,:)=fse3v_n (:,:,:) 467 IF ( lk_vvl ) THEN 468 fse3uw_b(:,:,:) = fse3uw_n(:,:,:) 469 fse3vw_b(:,:,:) = fse3vw_n(:,:,:) 470 fsdept_b(:,:,:) = fsdept_n(:,:,:) 471 fsdepw_b(:,:,:) = fsdepw_n(:,:,:) 472 hu_b(:,:) = hu(:,:) 473 hv_b(:,:) = hv(:,:) 474 hur_b(:,:) = hur(:,:) 475 hvr_b(:,:) = hvr(:,:) 476 END IF 477 !! 439 ! 440 ! deallocation tmp arrays 478 441 CALL wrk_dealloc(jpi,jpj,jpk,2, zts0 ) 479 442 CALL wrk_dealloc(jpi,jpj,jpk, ztmask0, ztmask1 , ztrp ) -
branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90
r5779 r5802 172 172 !!----------------------------------------------------------------------- 173 173 ! 174 glob_sum_full_2d = SUM( ptab(:,:) )174 glob_sum_full_2d = SUM( ptab(:,:) * tmask_h(:,:) ) 175 175 IF( lk_mpp ) CALL mpp_sum( glob_sum_full_2d ) 176 176 ! … … 194 194 glob_sum_full_3d = 0.e0 195 195 DO jk = 1, ijpk 196 glob_sum_full_3d = glob_sum_full_3d + SUM( ptab(:,:,jk) )196 glob_sum_full_3d = glob_sum_full_3d + SUM( ptab(:,:,jk) * tmask_h(:,:) ) 197 197 END DO 198 198 IF( lk_mpp ) CALL mpp_sum( glob_sum_full_3d ) … … 376 376 DO jj = 1, jpj 377 377 DO ji =1, jpi 378 ztmp = ptab(ji,jj) 378 ztmp = ptab(ji,jj) * tmask_h(ji,jj) 379 379 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 380 380 END DO … … 407 407 DO jj = 1, jpj 408 408 DO ji =1, jpi 409 ztmp = ptab(ji,jj,jk) 409 ztmp = ptab(ji,jj,jk) * tmask_h(ji,jj) 410 410 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 411 411 END DO
Note: See TracChangeset
for help on using the changeset viewer.