Changeset 2797
- Timestamp:
- 2011-07-11T12:53:56+02:00 (13 years ago)
- Location:
- branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 4 added
- 6 deleted
- 26 edited
-
BDY (deleted)
-
DIA/diahsb.F90 (modified) (2 diffs)
-
DOM/dommsk.F90 (modified) (1 diff)
-
DYN/divcur.F90 (modified) (3 diffs)
-
DYN/dynnxt.F90 (modified) (4 diffs)
-
DYN/dynspg.F90 (modified) (2 diffs)
-
DYN/dynspg_exp.F90 (modified) (2 diffs)
-
DYN/dynspg_flt.F90 (modified) (3 diffs)
-
DYN/dynspg_ts.F90 (modified) (5 diffs)
-
DYN/sshwzv.F90 (modified) (3 diffs)
-
LBC/lib_mpp.F90 (modified) (5 diffs)
-
OBC/obc_oce.F90 (modified) (1 diff)
-
OBC/obc_par.F90 (modified) (2 diffs)
-
OBC/obc_vectopt_loop_substitute.h90 (deleted)
-
OBC/obcdta.F90 (modified) (1 diff)
-
OBC/obcdyn.F90 (deleted)
-
OBC/obcdyn2d.F90 (added)
-
OBC/obcdyn3d.F90 (added)
-
OBC/obcdyn_bt.F90 (deleted)
-
OBC/obcfla.F90 (deleted)
-
OBC/obcice_lim2.F90 (added)
-
OBC/obcini.F90 (modified) (4 diffs)
-
OBC/obcrad.F90 (modified) (1 diff)
-
OBC/obcrst.F90 (deleted)
-
OBC/obctides.F90 (added)
-
OBC/obctra.F90 (modified) (2 diffs)
-
OBC/obcvol.F90 (modified) (1 diff)
-
SBC/fldread.F90 (modified) (13 diffs)
-
SBC/sbcapr.F90 (modified) (3 diffs)
-
SBC/sbcmod.F90 (modified) (2 diffs)
-
SOL/solmat.F90 (modified) (5 diffs)
-
SOL/solver.F90 (modified) (1 diff)
-
TRA/tranxt.F90 (modified) (5 diffs)
-
nemogcm.F90 (modified) (2 diffs)
-
step.F90 (modified) (2 diffs)
-
step_oce.F90 (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90
r2528 r2797 18 18 USE lib_mpp ! distributed memory computing library 19 19 USE trabbc ! bottom boundary condition 20 USE bdy_par ! (for lk_bdy)21 20 USE obc_par ! (for lk_obc) 22 21 … … 205 204 WRITE(numout,*) "dia_hsb: heat salt volume budgets activated" 206 205 WRITE(numout,*) "~~~~~~~ output written in the 'heat_salt_volume_budgets.txt' ASCII file" 207 IF( lk_obc .OR. lk_bdy) THEN206 IF( lk_obc ) THEN 208 207 CALL ctl_warn( 'dia_hsb does not take open boundary fluxes into account' ) 209 208 ENDIF -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
r2715 r2797 25 25 USE oce ! ocean dynamics and tracers 26 26 USE dom_oce ! ocean space and time domain 27 USE obc_oce ! ocean open boundary conditions28 27 USE in_out_manager ! I/O manager 29 28 USE lbclnk ! ocean lateral boundary conditions (or mpp link) -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90
r2715 r2797 27 27 USE sbc_oce, ONLY : ln_rnf ! surface boundary condition: ocean 28 28 USE sbcrnf ! river runoff 29 USE obc_oce ! ocean lateral open boundary condition30 29 USE cla ! cross land advection (cla_div routine) 31 30 USE in_out_manager ! I/O manager … … 121 120 END DO 122 121 123 #if defined key_obc124 IF( Agrif_Root() ) THEN125 ! open boundaries (div must be zero behind the open boundary)126 ! mpp remark: The zeroing of hdivn can probably be extended to 1->jpi/jpj for the correct row/column127 IF( lp_obc_east ) hdivn(nie0p1:nie1p1,nje0 :nje1 ,jk) = 0.e0 ! east128 IF( lp_obc_west ) hdivn(niw0 :niw1 ,njw0 :njw1 ,jk) = 0.e0 ! west129 IF( lp_obc_north ) hdivn(nin0 :nin1 ,njn0p1:njn1p1,jk) = 0.e0 ! north130 IF( lp_obc_south ) hdivn(nis0 :nis1 ,njs0 :njs1 ,jk) = 0.e0 ! south131 ENDIF132 #endif133 122 IF( .NOT. AGRIF_Root() ) THEN 134 123 IF ((nbondi == 1).OR.(nbondi == 2)) hdivn(nlci-1 , : ,jk) = 0.e0 ! east … … 304 293 END DO 305 294 306 #if defined key_obc307 IF( Agrif_Root() ) THEN308 ! open boundaries (div must be zero behind the open boundary)309 ! mpp remark: The zeroing of hdivn can probably be extended to 1->jpi/jpj for the correct row/column310 IF( lp_obc_east ) hdivn(nie0p1:nie1p1,nje0 :nje1 ,jk) = 0.e0 ! east311 IF( lp_obc_west ) hdivn(niw0 :niw1 ,njw0 :njw1 ,jk) = 0.e0 ! west312 IF( lp_obc_north ) hdivn(nin0 :nin1 ,njn0p1:njn1p1,jk) = 0.e0 ! north313 IF( lp_obc_south ) hdivn(nis0 :nis1 ,njs0 :njs1 ,jk) = 0.e0 ! south314 ENDIF315 #endif316 295 IF( .NOT. AGRIF_Root() ) THEN 317 296 IF ((nbondi == 1).OR.(nbondi == 2)) hdivn(nlci-1 , : ,jk) = 0.e0 ! east -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90
r2779 r2797 30 30 USE domvvl ! variable volume 31 31 USE obc_oce ! ocean open boundary conditions 32 USE obcdyn ! open boundary condition for momentum (obc_dyn routine)33 USE obcdyn _bt ! 2D open boundary condition for momentum (obc_dyn_bt routine)32 USE obcdyn3d ! open boundary condition for baroclinic velocities 33 USE obcdyn2d ! open boundary condition for barotropic variables 34 34 USE obcvol ! ocean open boundary condition (obc_vol routines) 35 USE bdy_oce ! unstructured open boundary conditions36 USE bdydta ! unstructured open boundary conditions37 USE bdydyn ! unstructured open boundary conditions38 35 USE in_out_manager ! I/O manager 39 36 USE lbclnk ! lateral boundary condition (or mpp link) … … 77 74 !! * Apply lateral boundary conditions on after velocity 78 75 !! at the local domain boundaries through lbc_lnk call, 79 !! at the radiative open boundaries (lk_obc=T), 80 !! at the relaxed open boundaries (lk_bdy=T), and 76 !! at the one-way open boundaries (lk_obc=T), 81 77 !! at the AGRIF zoom boundaries (lk_agrif=T) 82 78 !! … … 157 153 # if defined key_obc 158 154 ! !* OBC open boundaries 159 CALL obc_dyn( kt )160 !161 155 IF( .NOT. lk_dynspg_flt ) THEN 162 ! Flather boundary condition : - Update sea surface height on each open boundary 163 ! sshn (= after ssh ) for explicit case (lk_dynspg_exp=T) 164 ! sshn_b (= after ssha_b) for time-splitting case (lk_dynspg_ts=T) 165 ! - Correct the barotropic velocities 166 CALL obc_dyn_bt( kt ) 156 157 CALL obc_dyn3d( kt ) 158 ! 159 !!!! ENDA'S FIX: NEED TO THINK ABOUT THIS !!!! 160 CALL obc_dta( kt+1, jit=0 ) 161 CALL obc_dyn2d( kt, sshn_b ) 167 162 ! 168 163 !!gm ERROR - potential BUG: sshn should not be modified at this stage !! ssh_nxt not alrady called … … 174 169 ENDIF 175 170 ! 176 # elif defined key_bdy177 ! !* BDY open boundaries178 IF( .NOT. lk_dynspg_flt ) THEN179 CALL bdy_dyn_frs( kt )180 # if ! defined key_vvl181 ua_e(:,:) = 0.e0182 va_e(:,:) = 0.e0183 ! Set these variables for use in bdy_dyn_fla184 hur_e(:,:) = hur(:,:)185 hvr_e(:,:) = hvr(:,:)186 DO jk = 1, jpkm1 !! Vertically integrated momentum trends187 ua_e(:,:) = ua_e(:,:) + fse3u(:,:,jk) * umask(:,:,jk) * ua(:,:,jk)188 va_e(:,:) = va_e(:,:) + fse3v(:,:,jk) * vmask(:,:,jk) * va(:,:,jk)189 END DO190 ua_e(:,:) = ua_e(:,:) * hur(:,:)191 va_e(:,:) = va_e(:,:) * hvr(:,:)192 DO jk = 1 , jpkm1193 ua(:,:,jk) = ua(:,:,jk) - ua_e(:,:)194 va(:,:,jk) = va(:,:,jk) - va_e(:,:)195 END DO196 CALL bdy_dta_fla( kt+1, 0,2*nn_baro)197 CALL bdy_dyn_fla( sshn_b )198 CALL lbc_lnk( ua_e, 'U', -1. ) ! Boundary points should be updated199 CALL lbc_lnk( va_e, 'V', -1. ) !200 DO jk = 1 , jpkm1201 ua(:,:,jk) = ( ua(:,:,jk) + ua_e(:,:) ) * umask(:,:,jk)202 va(:,:,jk) = ( va(:,:,jk) + va_e(:,:) ) * vmask(:,:,jk)203 END DO204 # endif205 ENDIF206 171 # endif 207 172 ! -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90
r2715 r2797 15 15 USE dom_oce ! ocean space and time domain variables 16 16 USE phycst ! physical constants 17 USE obc_oce ! ocean open boundary conditions18 17 USE sbc_oce ! surface boundary condition: ocean 19 18 USE sbcapr ! surface boundary condition: atmospheric pressure … … 222 221 ENDIF 223 222 224 #if defined key_obc225 ! ! Conservation of ocean volume (key_dynspg_flt)226 IF( lk_dynspg_flt ) ln_vol_cst = .true.227 228 ! ! Application of Flather's algorithm at open boundaries229 IF( lk_dynspg_flt ) ln_obc_fla = .false.230 IF( lk_dynspg_exp ) ln_obc_fla = .true.231 IF( lk_dynspg_ts ) ln_obc_fla = .true.232 #endif233 223 ! 234 224 END SUBROUTINE dyn_spg_init -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_exp.F90
r2715 r2797 20 20 USE obc_oce ! Lateral open boundary condition 21 21 USE phycst ! physical constants 22 USE obc_par ! open boundary condition parameters23 22 USE obcdta ! open boundary condition data (obc_dta_bt routine) 24 23 USE in_out_manager ! I/O manager … … 78 77 79 78 !!gm bug ?? Rachid we have to discuss of the call below. I don't understand why it is here and not in ssh_wzv 80 IF( lk_obc ) CALL obc_dta _bt( kt,0 ) ! OBC: read or estimate ssh and vertically integrated velocities79 IF( lk_obc ) CALL obc_dta( kt, jit=0 ) ! OBC: read or estimate ssh and vertically integrated velocities 81 80 !!gm 82 81 -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90
r2715 r2797 33 33 USE solpcg ! preconditionned conjugate gradient solver 34 34 USE solsor ! Successive Over-relaxation solver 35 USE obcdyn ! ocean open boundary condition (obc_dynroutines)35 USE obcdyn3d ! ocean open boundary condition (obc_dyn3d routines) 36 36 USE obcvol ! ocean open boundary condition (obc_vol routines) 37 USE bdy_oce ! Unstructured open boundaries condition38 USE bdydyn ! Unstructured open boundaries condition (bdy_dyn routine)39 USE bdyvol ! Unstructured open boundaries condition (bdy_vol routine)40 37 USE cla ! cross land advection 41 38 USE in_out_manager ! I/O manager … … 183 180 184 181 #if defined key_obc 185 CALL obc_dyn ( kt ) ! Update velocities on each open boundary with the radiation algorithm182 CALL obc_dyn3d( kt ) ! Update velocities on each open boundary 186 183 CALL obc_vol( kt ) ! Correction of the barotropic componant velocity to control the volume of the system 187 #endif188 #if defined key_bdy189 CALL bdy_dyn_frs( kt ) ! Update velocities on unstructured boundary using the Flow Relaxation Scheme190 CALL bdy_vol( kt ) ! Correction of the barotropic component velocity to control the volume of the system191 184 #endif 192 185 #if defined key_agrif … … 304 297 #if defined key_obc 305 298 ! caution : grad D = 0 along open boundaries 299 ! Remark: The filtering force could be reduced here in the FRS zone 300 ! by multiplying spgu/spgv by (1-alpha) ?? 306 301 spgu(ji,jj) = z2dt * ztdgu * obcumask(ji,jj) 307 302 spgv(ji,jj) = z2dt * ztdgv * obcvmask(ji,jj) 308 #elif defined key_bdy309 ! caution : grad D = 0 along open boundaries310 ! Remark: The filtering force could be reduced here in the FRS zone311 ! by multiplying spgu/spgv by (1-alpha) ??312 spgu(ji,jj) = z2dt * ztdgu * bdyumask(ji,jj)313 spgv(ji,jj) = z2dt * ztdgv * bdyvmask(ji,jj)314 303 #else 315 304 spgu(ji,jj) = z2dt * ztdgu -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90
r2724 r2797 25 25 USE domvvl ! variable volume 26 26 USE zdfbfr ! bottom friction 27 USE obcdta ! open boundary condition data28 USE obcfla ! Flather open boundary condition29 27 USE dynvor ! vorticity term 30 28 USE obc_oce ! Lateral open boundary condition 31 USE obc_par ! open boundary condition parameters 32 USE bdy_oce ! unstructured open boundaries 33 USE bdy_par ! unstructured open boundaries 34 USE bdydta ! unstructured open boundaries 35 USE bdydyn ! unstructured open boundaries 36 USE bdytides ! tidal forcing at unstructured open boundaries. 29 USE obcdta ! open boundary condition data 30 USE obcdyn2d ! open boundary conditions on barotropic variables 37 31 USE lib_mpp ! distributed memory computing library 38 32 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 352 346 zssh_sum(:,:) = sshn (:,:) 353 347 354 #if defined key_obc355 ! set ssh corrections to 0356 ! ssh corrections are applied to normal velocities (Flather's algorithm) and averaged over the barotropic loop357 IF( lp_obc_east ) sshfoe_b(:,:) = 0.e0358 IF( lp_obc_west ) sshfow_b(:,:) = 0.e0359 IF( lp_obc_south ) sshfos_b(:,:) = 0.e0360 IF( lp_obc_north ) sshfon_b(:,:) = 0.e0361 #endif362 363 348 ! ! ==================== ! 364 349 DO jn = 1, icycle ! sub-time-step loop ! (from NOW to AFTER+1) … … 367 352 IF( jn == 1 ) z2dt_e = rdt / nn_baro 368 353 369 ! !* Update the forcing (OBC , BDYand tides)354 ! !* Update the forcing (OBC and tides) 370 355 ! ! ------------------ 371 IF( lk_obc ) CALL obc_dta_bt ( kt, jn ) 372 IF( lk_bdy ) CALL bdy_dta_fla( kt, jn+1, icycle ) 356 IF( lk_obc ) CALL obc_dta ( kt, jit=jn ) 373 357 374 358 ! !* after ssh_e … … 384 368 ! 385 369 #if defined key_obc 386 ! ! OBC : zhdiv must be zero behind the open boundary 387 !! mpp remark: The zeroing of hdiv can probably be extended to 1->jpi/jpj for the correct row/column 388 IF( lp_obc_east ) zhdiv(nie0p1:nie1p1,nje0 :nje1 ) = 0.e0 ! east 389 IF( lp_obc_west ) zhdiv(niw0 :niw1 ,njw0 :njw1 ) = 0.e0 ! west 390 IF( lp_obc_north ) zhdiv(nin0 :nin1 ,njn0p1:njn1p1) = 0.e0 ! north 391 IF( lp_obc_south ) zhdiv(nis0 :nis1 ,njs0 :njs1 ) = 0.e0 ! south 392 #endif 393 #if defined key_bdy 394 zhdiv(:,:) = zhdiv(:,:) * bdytmask(:,:) ! BDY mask 370 zhdiv(:,:) = zhdiv(:,:) * obctmask(:,:) ! OBC mask 395 371 #endif 396 372 ! … … 489 465 ! !* domain lateral boundary 490 466 ! ! ----------------------- 491 ! ! Flather's boundary condition for the barotropic loop : 492 ! ! - Update sea surface height on each open boundary 493 ! ! - Correct the velocity 494 495 IF( lk_obc ) CALL obc_fla_ts ( ua_e, va_e, sshn_e, ssha_e ) 496 IF( lk_bdy .OR. ln_tides ) CALL bdy_dyn_fla( sshn_e ) 467 ! OBC open boundaries 468 IF( lk_obc .OR. ln_tides ) CALL obc_dyn2d( kt, sshn_e ) 497 469 ! 498 470 CALL lbc_lnk( ua_e , 'U', -1. ) ! local domain boundaries -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90
r2715 r2797 26 26 USE lbclnk ! ocean lateral boundary condition (or mpp link) 27 27 USE lib_mpp ! MPP library 28 USE obc_par ! open boundary cond. parameter29 28 USE obc_oce 30 USE bdy_oce31 29 USE diaar5, ONLY: lk_diaar5 32 30 USE iom … … 175 173 #endif 176 174 #if defined key_obc 177 IF( Agrif_Root() ) THEN 178 ssha(:,:) = ssha(:,:) * obctmsk(:,:) 179 CALL lbc_lnk( ssha, 'T', 1. ) ! absolutly compulsory !! (jmm) 180 ENDIF 181 #endif 182 #if defined key_bdy 183 ssha(:,:) = ssha(:,:) * bdytmask(:,:) 184 CALL lbc_lnk( ssha, 'T', 1. ) 175 ssha(:,:) = ssha(:,:) * obctmask(:,:) 176 CALL lbc_lnk( ssha, 'T', 1. ) ! absolutly compulsory !! (jmm) 185 177 #endif 186 178 … … 217 209 & - ( fse3t_a(:,:,jk) - fse3t_b(:,:,jk) ) & 218 210 & * tmask(:,:,jk) * z1_2dt 219 #if defined key_ bdy220 wn(:,:,jk) = wn(:,:,jk) * bdytmask(:,:)211 #if defined key_obc 212 wn(:,:,jk) = wn(:,:,jk) * obctmask(:,:) 221 213 #endif 222 214 END DO -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r2731 r2797 47 47 !! mppsync : 48 48 !! mppstop : 49 !! mppobc : variant of mpp_lnk for open boundary condition50 49 !! mpp_ini_north : initialisation of north fold 51 50 !! mpp_lbc_north : north fold processors gathering … … 64 63 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 65 64 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 66 PUBLIC mpp obc, mpp_ini_ice, mpp_ini_znl65 PUBLIC mpp_ini_ice, mpp_ini_znl 67 66 PUBLIC mppsize 68 67 PUBLIC lib_mpp_alloc ! Called in nemogcm.F90 … … 1726 1725 END SUBROUTINE mppstop 1727 1726 1728 1729 SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij , kumout)1730 !!----------------------------------------------------------------------1731 !! *** routine mppobc ***1732 !!1733 !! ** Purpose : Message passing manadgement for open boundary1734 !! conditions array1735 !!1736 !! ** Method : Use mppsend and mpprecv function for passing mask1737 !! between processors following neighboring subdomains.1738 !! domain parameters1739 !! nlci : first dimension of the local subdomain1740 !! nlcj : second dimension of the local subdomain1741 !! nbondi : mark for "east-west local boundary"1742 !! nbondj : mark for "north-south local boundary"1743 !! noea : number for local neighboring processors1744 !! nowe : number for local neighboring processors1745 !! noso : number for local neighboring processors1746 !! nono : number for local neighboring processors1747 !!1748 !!----------------------------------------------------------------------1749 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released1750 USE wrk_nemo, ONLY: ztab => wrk_2d_11751 !1752 INTEGER , INTENT(in ) :: kd1, kd2 ! starting and ending indices1753 INTEGER , INTENT(in ) :: kl ! index of open boundary1754 INTEGER , INTENT(in ) :: kk ! vertical dimension1755 INTEGER , INTENT(in ) :: ktype ! define north/south or east/west cdt1756 ! ! = 1 north/south ; = 2 east/west1757 INTEGER , INTENT(in ) :: kij ! horizontal dimension1758 INTEGER , INTENT(in ) :: kumout ! ocean.output logical unit1759 REAL(wp), INTENT(inout), DIMENSION(kij,kk) :: ptab ! variable array1760 !1761 INTEGER :: ji, jj, jk, jl ! dummy loop indices1762 INTEGER :: iipt0, iipt1, ilpt1 ! local integers1763 INTEGER :: ijpt0, ijpt1 ! - -1764 INTEGER :: imigr, iihom, ijhom ! - -1765 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1766 INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend1767 !!----------------------------------------------------------------------1768 1769 IF( wrk_in_use(2, 1) ) THEN1770 WRITE(kumout, cform_err)1771 WRITE(kumout,*) 'mppobc : requested workspace array unavailable'1772 CALL mppstop1773 ENDIF1774 1775 ! boundary condition initialization1776 ! ---------------------------------1777 ztab(:,:) = 0.e01778 !1779 IF( ktype==1 ) THEN ! north/south boundaries1780 iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci ) )1781 iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )1782 ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci ) )1783 ijpt0 = MAX( 1, MIN(kl - njmpp+1, nlcj ) )1784 ijpt1 = MAX( 0, MIN(kl - njmpp+1, nlcj - 1 ) )1785 ELSEIF( ktype==2 ) THEN ! east/west boundaries1786 iipt0 = MAX( 1, MIN(kl - nimpp+1, nlci ) )1787 iipt1 = MAX( 0, MIN(kl - nimpp+1, nlci - 1 ) )1788 ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj ) )1789 ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )1790 ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) )1791 ELSE1792 WRITE(kumout, cform_err)1793 WRITE(kumout,*) 'mppobc : bad ktype'1794 CALL mppstop1795 ENDIF1796 1797 ! Communication level by level1798 ! ----------------------------1799 !!gm Remark : this is very time consumming!!!1800 ! ! ------------------------ !1801 DO jk = 1, kk ! Loop over the levels !1802 ! ! ------------------------ !1803 !1804 IF( ktype == 1 ) THEN ! north/south boundaries1805 DO jj = ijpt0, ijpt11806 DO ji = iipt0, iipt11807 ztab(ji,jj) = ptab(ji,jk)1808 END DO1809 END DO1810 ELSEIF( ktype == 2 ) THEN ! east/west boundaries1811 DO jj = ijpt0, ijpt11812 DO ji = iipt0, iipt11813 ztab(ji,jj) = ptab(jj,jk)1814 END DO1815 END DO1816 ENDIF1817 1818 1819 ! 1. East and west directions1820 ! ---------------------------1821 !1822 IF( nbondi /= 2 ) THEN ! Read Dirichlet lateral conditions1823 iihom = nlci-nreci1824 DO jl = 1, jpreci1825 t2ew(:,jl,1) = ztab(jpreci+jl,:)1826 t2we(:,jl,1) = ztab(iihom +jl,:)1827 END DO1828 ENDIF1829 !1830 ! ! Migrations1831 imigr=jpreci*jpj1832 !1833 IF( nbondi == -1 ) THEN1834 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )1835 CALL mpprecv( 1, t2ew(1,1,2), imigr )1836 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )1837 ELSEIF( nbondi == 0 ) THEN1838 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )1839 CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )1840 CALL mpprecv( 1, t2ew(1,1,2), imigr )1841 CALL mpprecv( 2, t2we(1,1,2), imigr )1842 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )1843 IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err )1844 ELSEIF( nbondi == 1 ) THEN1845 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )1846 CALL mpprecv( 2, t2we(1,1,2), imigr )1847 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )1848 ENDIF1849 !1850 ! ! Write Dirichlet lateral conditions1851 iihom = nlci-jpreci1852 !1853 IF( nbondi == 0 .OR. nbondi == 1 ) THEN1854 DO jl = 1, jpreci1855 ztab(jl,:) = t2we(:,jl,2)1856 END DO1857 ENDIF1858 IF( nbondi == -1 .OR. nbondi == 0 ) THEN1859 DO jl = 1, jpreci1860 ztab(iihom+jl,:) = t2ew(:,jl,2)1861 END DO1862 ENDIF1863 1864 1865 ! 2. North and south directions1866 ! -----------------------------1867 !1868 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions1869 ijhom = nlcj-nrecj1870 DO jl = 1, jprecj1871 t2sn(:,jl,1) = ztab(:,ijhom +jl)1872 t2ns(:,jl,1) = ztab(:,jprecj+jl)1873 END DO1874 ENDIF1875 !1876 ! ! Migrations1877 imigr = jprecj * jpi1878 !1879 IF( nbondj == -1 ) THEN1880 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )1881 CALL mpprecv( 3, t2ns(1,1,2), imigr )1882 IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )1883 ELSEIF( nbondj == 0 ) THEN1884 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )1885 CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )1886 CALL mpprecv( 3, t2ns(1,1,2), imigr )1887 CALL mpprecv( 4, t2sn(1,1,2), imigr )1888 IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )1889 IF( l_isend ) CALL mpi_wait( ml_req2, ml_stat, ml_err )1890 ELSEIF( nbondj == 1 ) THEN1891 CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )1892 CALL mpprecv( 4, t2sn(1,1,2), imigr)1893 IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )1894 ENDIF1895 !1896 ! ! Write Dirichlet lateral conditions1897 ijhom = nlcj - jprecj1898 IF( nbondj == 0 .OR. nbondj == 1 ) THEN1899 DO jl = 1, jprecj1900 ztab(:,jl) = t2sn(:,jl,2)1901 END DO1902 ENDIF1903 IF( nbondj == 0 .OR. nbondj == -1 ) THEN1904 DO jl = 1, jprecj1905 ztab(:,ijhom+jl) = t2ns(:,jl,2)1906 END DO1907 ENDIF1908 IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN1909 DO jj = ijpt0, ijpt1 ! north/south boundaries1910 DO ji = iipt0,ilpt11911 ptab(ji,jk) = ztab(ji,jj)1912 END DO1913 END DO1914 ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN1915 DO jj = ijpt0, ilpt1 ! east/west boundaries1916 DO ji = iipt0,iipt11917 ptab(jj,jk) = ztab(ji,jj)1918 END DO1919 END DO1920 ENDIF1921 !1922 END DO1923 !1924 IF( wrk_not_released(2, 1) ) THEN1925 WRITE(kumout, cform_err)1926 WRITE(kumout,*) 'mppobc : failed to release workspace array'1927 CALL mppstop1928 ENDIF1929 !1930 END SUBROUTINE mppobc1931 1932 1933 1727 SUBROUTINE mpp_comm_free( kcom ) 1934 1728 !!---------------------------------------------------------------------- … … 2488 2282 MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 2489 2283 END INTERFACE 2490 INTERFACE mppobc2491 MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d2492 END INTERFACE2493 2284 INTERFACE mpp_minloc 2494 2285 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d … … 2603 2394 WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom 2604 2395 END SUBROUTINE mppmin_int 2605 2606 SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij, knum )2607 INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum2608 REAL, DIMENSION(:) :: parr ! variable array2609 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij, knum2610 END SUBROUTINE mppobc_1d2611 2612 SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij, knum )2613 INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum2614 REAL, DIMENSION(:,:) :: parr ! variable array2615 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij, knum2616 END SUBROUTINE mppobc_2d2617 2618 SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij, knum )2619 INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum2620 REAL, DIMENSION(:,:,:) :: parr ! variable array2621 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij, knum2622 END SUBROUTINE mppobc_3d2623 2624 SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij, knum )2625 INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum2626 REAL, DIMENSION(:,:,:,:) :: parr ! variable array2627 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij, knum2628 END SUBROUTINE mppobc_4d2629 2396 2630 2397 SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj ) -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obc_oce.F90
r2715 r2797 1 1 MODULE obc_oce 2 !!====================================================================== ========2 !!====================================================================== 3 3 !! *** MODULE obc_oce *** 4 !! Open Boundary Cond. : define related variables 5 !!============================================================================== 6 !! history : OPA ! 1991-01 (CLIPPER) Original code 7 !! NEMO 1.0 ! 2002-02 (C. Talandier) modules, F90 4 !! Unstructured Open Boundary Cond. : define related variables 5 !!====================================================================== 6 !! History : 1.0 ! 2001-05 (J. Chanut, A. Sellar) Original code 7 !! 3.0 ! 2008-04 (NEMO team) add in the reference version 8 !! 3.3 ! 2010-09 (D. Storkey) add ice boundary conditions 9 !! 3.4 ! 2011 (D. Storkey, J. Chanut) OBC-BDY merge 8 10 !!---------------------------------------------------------------------- 9 #if defined key_obc 11 #if defined key_obc 10 12 !!---------------------------------------------------------------------- 11 !! 'key_obc' :Open Boundary Condition13 !! 'key_obc' Unstructured Open Boundary Condition 12 14 !!---------------------------------------------------------------------- 13 15 USE par_oce ! ocean parameters 14 USE obc_par ! open boundary condition parameters 16 USE obc_par ! Unstructured boundary parameters 17 USE lib_mpp ! distributed memory computing 15 18 16 19 IMPLICIT NONE 17 20 PUBLIC 18 19 PUBLIC obc_oce_alloc ! called by obcini.F90 module 21 22 TYPE, PUBLIC :: OBC_INDEX !: Indices and weights which define the open boundary 23 INTEGER, DIMENSION(jpbgrd) :: nblen 24 INTEGER, DIMENSION(jpbgrd) :: nblenrim 25 INTEGER, POINTER, DIMENSION(:,:) :: nbi 26 INTEGER, POINTER, DIMENSION(:,:) :: nbj 27 INTEGER, POINTER, DIMENSION(:,:) :: nbr 28 INTEGER, POINTER, DIMENSION(:,:) :: nbmap 29 REAL , POINTER, DIMENSION(:,:) :: nbw 30 REAL , POINTER, DIMENSION(:) :: flagu 31 REAL , POINTER, DIMENSION(:) :: flagv 32 END TYPE OBC_INDEX 33 34 TYPE, PUBLIC :: OBC_DATA !: Storage for external data 35 REAL, POINTER, DIMENSION(:) :: ssh 36 REAL, POINTER, DIMENSION(:) :: u2d 37 REAL, POINTER, DIMENSION(:) :: v2d 38 REAL, POINTER, DIMENSION(:,:) :: u3d 39 REAL, POINTER, DIMENSION(:,:) :: v3d 40 REAL, POINTER, DIMENSION(:,:) :: tem 41 REAL, POINTER, DIMENSION(:,:) :: sal 42 #if defined key_lim2 43 REAL, POINTER, DIMENSION(:) :: frld 44 REAL, POINTER, DIMENSION(:) :: hicif 45 REAL, POINTER, DIMENSION(:) :: hsnif 46 #endif 47 END TYPE OBC_DATA 20 48 21 49 !!---------------------------------------------------------------------- 22 !! open boundaryvariables50 !! Namelist variables 23 51 !!---------------------------------------------------------------------- 52 CHARACTER(len=80), DIMENSION(jp_obc) :: cn_coords_file !: Name of obc coordinates file 53 CHARACTER(len=80) :: cn_mask_file !: Name of obc mask file 24 54 ! 25 ! !!* Namelist namobc: open boundary condition * 26 INTEGER :: nn_obcdta = 0 !: = 0 use the initial state as obc data 27 ! ! = 1 read obc data in obcxxx.dta files 28 CHARACTER(len=20) :: cn_obcdta = 'annual' !: set to annual if obc datafile hold 1 year of data 29 ! ! set to monthly if obc datafile hold 1 month of data 30 LOGICAL :: ln_obc_clim = .true. !: obc data files are climatological 31 LOGICAL :: ln_obc_fla = .false. !: Flather open boundary condition not used 32 LOGICAL :: ln_vol_cst = .true. !: Conservation of the whole volume 33 REAL(wp) :: rn_dpein = 1. !: damping time scale for inflow at East open boundary 34 REAL(wp) :: rn_dpwin = 1. !: " " at West open boundary 35 REAL(wp) :: rn_dpsin = 1. !: " " at South open boundary 36 REAL(wp) :: rn_dpnin = 1. !: " " at North open boundary 37 REAL(wp) :: rn_dpeob = 15. !: damping time scale for the climatology at East open boundary 38 REAL(wp) :: rn_dpwob = 15. !: " " at West open boundary 39 REAL(wp) :: rn_dpsob = 15. !: " " at South open boundary 40 REAL(wp) :: rn_dpnob = 15. !: " " at North open boundary 41 REAL(wp) :: rn_volemp = 1. !: = 0 the total volume will have the variability of the 42 ! ! surface Flux E-P else (volemp = 1) the volume will be constant 43 ! ! = 1 the volume will be constant during all the integration. 55 LOGICAL, DIMENSION(jp_obc) :: ln_coords_file !: =T read obc coordinates from file; 56 ! !: =F read obc coordinates from namelist 57 LOGICAL :: ln_mask_file !: =T read obcmask from file 58 LOGICAL, DIMENSION(jp_obc) :: ln_tides !: =T apply tidal harmonic forcing along open boundaries 59 LOGICAL :: ln_vol !: =T volume correction 60 LOGICAL, DIMENSION(jp_obc) :: ln_clim !: =T obc data files contain climatological data (time-cyclic) 61 ! 62 INTEGER :: nb_obc !: number of open boundary sets 63 INTEGER, DIMENSION(jp_obc) :: nn_rimwidth !: boundary rim width 64 INTEGER, DIMENSION(jp_obc) :: nn_dtactl !: = 0 use the initial state as obc dta ; 65 !: = 1 read it in a NetCDF file 66 INTEGER :: nn_volctl !: = 0 the total volume will have the variability of the surface Flux E-P 67 ! ! = 1 the volume will be constant during all the integration. 68 INTEGER, DIMENSION(jp_obc) :: nn_dyn2d ! Choice of boundary condition for barotropic variables (U,V,SSH) 69 INTEGER, DIMENSION(jp_obc) :: nn_dyn3d ! Choice of boundary condition for baroclinic velocities 70 INTEGER, DIMENSION(jp_obc) :: nn_tra ! Choice of boundary condition for active tracers (T and S) 71 #if defined key_lim2 72 INTEGER, DIMENSION(jp_obc) :: nn_ice_lim2 ! Choice of boundary condition for sea ice variables 73 #endif 74 ! 75 INTEGER, DIMENSION(jp_obc) :: nn_dmp2d_in ! Damping timescale (days) for 2D solution for inward radiation or FRS 76 INTEGER, DIMENSION(jp_obc) :: nn_dmp2d_out ! Damping timescale (days) for 2D solution for outward radiation 77 INTEGER, DIMENSION(jp_obc) :: nn_dmp3d_in ! Damping timescale (days) for 3D solution for inward radiation or FRS 78 INTEGER, DIMENSION(jp_obc) :: nn_dmp3d_out ! Damping timescale (days) for 3D solution for outward radiation 44 79 45 ! !!! OLD non-DOCTOR name of namelist variables 46 INTEGER :: nbobc !: number of open boundaries ( 1=< nbobc =< 4 ) 47 INTEGER :: nobc_dta !: = 0 use the initial state as obc data 48 REAL(wp) :: rdpein !: damping time scale for inflow at East open boundary 49 REAL(wp) :: rdpwin !: " " at West open boundary 50 REAL(wp) :: rdpsin !: " " at South open boundary 51 REAL(wp) :: rdpnin !: " " at North open boundary 52 REAL(wp) :: rdpeob !: damping time scale for the climatology at East open boundary 53 REAL(wp) :: rdpwob !: " " at West open boundary 54 REAL(wp) :: rdpsob !: " " at South open boundary 55 REAL(wp) :: rdpnob !: " " at North open boundary 56 REAL(wp) :: volemp !: = 0 the total volume will have the variability of the 57 CHARACTER(len=20) :: cffile 80 81 !!---------------------------------------------------------------------- 82 !! Global variables 83 !!---------------------------------------------------------------------- 84 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: obctmask !: Mask defining computational domain at T-points 85 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: obcumask !: Mask defining computational domain at U-points 86 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: obcvmask !: Mask defining computational domain at V-points 58 87 59 60 !!General variables for open boundaries: 61 !!-------------------------------------- 62 LOGICAL :: lfbceast, lfbcwest !: logical flag for a fixed East and West open boundaries 63 LOGICAL :: lfbcnorth, lfbcsouth !: logical flag for a fixed North and South open boundaries 64 ! ! These logical flags are set to 'true' if damping time 65 ! ! scale are set to 0 in the namelist, for both inflow and outflow). 66 67 REAL(wp), PUBLIC :: obcsurftot !: Total lateral surface of open boundaries 68 69 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: & !: 70 obctmsk, & !: mask array identical to tmask, execpt along OBC where it is set to 0 71 ! ! it used to calculate the cumulate flux E-P in the obcvol.F90 routine 72 obcumask, obcvmask !: u-, v- Force filtering mask for the open 73 ! ! boundary condition on grad D 74 75 !!-------------------- 76 !! East open boundary: 77 !!-------------------- 78 INTEGER :: nie0 , nie1 !: do loop index in mpp case for jpieob 79 INTEGER :: nie0p1, nie1p1 !: do loop index in mpp case for jpieob+1 80 INTEGER :: nie0m1, nie1m1 !: do loop index in mpp case for jpieob-1 81 INTEGER :: nje0 , nje1 !: do loop index in mpp case for jpjed, jpjef 82 INTEGER :: nje0p1, nje1m1 !: do loop index in mpp case for jpjedp1,jpjefm1 83 INTEGER :: nje1m2, nje0m1 !: do loop index in mpp case for jpjefm1-1,jpjed 84 85 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: & !: 86 sshfoe, & !: now climatology of the east boundary sea surface height 87 ubtfoe,vbtfoe !: now climatology of the east boundary barotropic transport 88 89 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: & !: 90 ufoe, vfoe, & !: now climatology of the east boundary velocities 91 tfoe, sfoe, & !: now climatology of the east boundary temperature and salinity 92 uclie !: baroclinic componant of the zonal velocity after radiation 93 ! ! in the obcdyn.F90 routine 94 95 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshfoe_b !: east boundary ssh correction averaged over the barotropic loop 96 ! ! (if Flather's algoritm applied at open boundary) 97 98 !!------------------------------- 99 !! Arrays for radiative East OBC: 100 !!------------------------------- 101 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: uebnd, vebnd !: baroclinic u & v component of the velocity over 3 rows 102 ! ! and 3 time step (now, before, and before before) 103 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tebnd, sebnd !: East boundary temperature and salinity over 2 rows 104 ! ! and 2 time step (now and before) 105 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_cxebnd, v_cxebnd !: Zonal component of the phase speed ratio computed with 106 ! ! radiation of u and v velocity (respectively) at the 107 ! ! east open boundary (u_cxebnd = cx rdt ) 108 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: uemsk, vemsk, temsk !: 2D mask for the East OB 109 110 ! Note that those arrays are optimized for mpp case 111 ! (hence the dimension jpj is the size of one processor subdomain) 112 113 !!-------------------- 114 !! West open boundary 115 !!-------------------- 116 INTEGER :: niw0 , niw1 !: do loop index in mpp case for jpiwob 117 INTEGER :: niw0p1, niw1p1 !: do loop index in mpp case for jpiwob+1 118 INTEGER :: njw0 , njw1 !: do loop index in mpp case for jpjwd, jpjwf 119 INTEGER :: njw0p1, njw1m1 !: do loop index in mpp case for jpjwdp1,jpjwfm1 120 INTEGER :: njw1m2, njw0m1 !: do loop index in mpp case for jpjwfm2,jpjwd 121 122 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: & !: 123 sshfow, & !: now climatology of the west boundary sea surface height 124 ubtfow,vbtfow !: now climatology of the west boundary barotropic transport 125 126 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: & !: 127 ufow, vfow, & !: now climatology of the west velocities 128 tfow, sfow, & !: now climatology of the west temperature and salinity 129 ucliw !: baroclinic componant of the zonal velocity after the radiation 130 ! ! in the obcdyn.F90 routine 131 132 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshfow_b !: west boundary ssh correction averaged over the barotropic loop 133 ! ! (if Flather's algoritm applied at open boundary) 134 135 !!------------------------------- 136 !! Arrays for radiative West OBC 137 !!------------------------------- 138 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: uwbnd, vwbnd !: baroclinic u & v components of the velocity over 3 rows 139 ! ! and 3 time step (now, before, and before before) 140 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: twbnd, swbnd !: west boundary temperature and salinity over 2 rows and 141 ! ! 2 time step (now and before) 142 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_cxwbnd, v_cxwbnd !: Zonal component of the phase speed ratio computed with 143 ! ! radiation of zonal and meridional velocity (respectively) 144 ! ! at the west open boundary (u_cxwbnd = cx rdt ) 145 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: uwmsk, vwmsk, twmsk !: 2D mask for the West OB 146 147 ! Note that those arrays are optimized for mpp case 148 ! (hence the dimension jpj is the size of one processor subdomain) 149 150 !!--------------------- 151 !! North open boundary 152 !!--------------------- 153 INTEGER :: nin0 , nin1 !: do loop index in mpp case for jpind, jpinf 154 INTEGER :: nin0p1, nin1m1 !: do loop index in mpp case for jpindp1, jpinfm1 155 INTEGER :: nin1m2, nin0m1 !: do loop index in mpp case for jpinfm1-1,jpind 156 INTEGER :: njn0 , njn1 !: do loop index in mpp case for jpnob 157 INTEGER :: njn0p1, njn1p1 !: do loop index in mpp case for jpnob+1 158 INTEGER :: njn0m1, njn1m1 !: do loop index in mpp case for jpnob-1 159 160 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: & !: 161 sshfon, & !: now climatology of the north boundary sea surface height 162 ubtfon,vbtfon !: now climatology of the north boundary barotropic transport 163 164 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: & !: 165 ufon, vfon, & !: now climatology of the north boundary velocities 166 tfon, sfon, & !: now climatology of the north boundary temperature and salinity 167 vclin !: baroclinic componant of the meridian velocity after the radiation 168 ! ! in yhe obcdyn.F90 routine 169 170 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshfon_b !: north boundary ssh correction averaged over the barotropic loop 171 ! ! (if Flather's algoritm applied at open boundary) 172 173 !!-------------------------------- 174 !! Arrays for radiative North OBC 175 !!-------------------------------- 176 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: unbnd, vnbnd !: baroclinic u & v components of the velocity over 3 177 ! ! rows and 3 time step (now, before, and before before) 178 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tnbnd, snbnd !: north boundary temperature and salinity over 179 ! ! 2 rows and 2 time step (now and before) 180 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_cynbnd, v_cynbnd !: Meridional component of the phase speed ratio compu- 181 ! ! ted with radiation of zonal and meridional velocity 182 ! ! (respectively) at the north OB (u_cynbnd = cx rdt ) 183 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: unmsk, vnmsk, tnmsk !: 2D mask for the North OB 184 185 ! Note that those arrays are optimized for mpp case 186 ! (hence the dimension jpj is the size of one processor subdomain) 187 188 !!--------------------- 189 !! South open boundary 190 !!--------------------- 191 INTEGER :: nis0 , nis1 !: do loop index in mpp case for jpisd, jpisf 192 INTEGER :: nis0p1, nis1m1 !: do loop index in mpp case for jpisdp1, jpisfm1 193 INTEGER :: nis1m2, nis0m1 !: do loop index in mpp case for jpisfm1-1,jpisd 194 INTEGER :: njs0 , njs1 !: do loop index in mpp case for jpsob 195 INTEGER :: njs0p1, njs1p1 !: do loop index in mpp case for jpsob+1 196 197 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: & !: 198 sshfos, & !: now climatology of the south boundary sea surface height 199 ubtfos,vbtfos !: now climatology of the south boundary barotropic transport 200 201 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: & !: 202 ufos, vfos, & !: now climatology of the south boundary velocities 203 tfos, sfos, & !: now climatology of the south boundary temperature and salinity 204 vclis !: baroclinic componant of the meridian velocity after the radiation 205 ! ! in the obcdyn.F90 routine 206 207 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshfos_b !: south boundary ssh correction averaged over the barotropic loop 208 ! ! (if Flather's algoritm applied at open boundary) 209 210 !!-------------------------------- 211 !! Arrays for radiative South OBC (computed by the forward time step in dynspg) 212 !!-------------------------------- 213 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: usbnd, vsbnd !: baroclinic u & v components of the velocity over 3 214 ! ! rows and 3 time step (now, before, and before before) 215 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tsbnd, ssbnd !: south boundary temperature and salinity over 216 ! ! 2 rows and 2 time step (now and before) 217 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_cysbnd, v_cysbnd !: Meridional component of the phase speed ratio 218 ! ! computed with radiation of zonal and meridional velocity 219 ! ! (repsectively) at the south OB (u_cynbnd = cx rdt ) 220 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: usmsk, vsmsk, tsmsk !: 2D mask for the South OB 88 REAL(wp) :: obcsurftot !: Lateral surface of unstructured open boundary 221 89 222 90 !!---------------------------------------------------------------------- 223 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 91 !! open boundary data variables 92 !!---------------------------------------------------------------------- 93 94 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: dta_global !: workspace for reading in global data arrays 95 TYPE(OBC_INDEX), DIMENSION(jp_obc), TARGET :: idx_obc !: obc indices (local process) 96 TYPE(OBC_DATA) , DIMENSION(jp_obc) :: dta_obc !: obc external data (local process) 97 98 !!---------------------------------------------------------------------- 99 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 224 100 !! $Id$ 225 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)101 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 226 102 !!---------------------------------------------------------------------- 227 103 CONTAINS 228 104 229 INTEGERFUNCTION obc_oce_alloc()105 FUNCTION obc_oce_alloc() 230 106 !!---------------------------------------------------------------------- 231 !! *** FUNCTION obc_oce_alloc *** 107 USE lib_mpp, ONLY: ctl_warn, mpp_sum 108 ! 109 INTEGER :: obc_oce_alloc 232 110 !!---------------------------------------------------------------------- 233 234 ALLOCATE( & 235 !! East open boundary 236 obctmsk(jpi,jpj), obcumask(jpi,jpj), obcvmask(jpi,jpj), & 237 sshfoe(jpjed:jpjef), ubtfoe(jpjed:jpjef), vbtfoe(jpjed:jpjef), & 238 ufoe(jpj,jpk), vfoe(jpj,jpk), tfoe(jpj,jpk), sfoe(jpj,jpk), & 239 uclie(jpj,jpk), sshfoe_b(jpjed:jpjef,jpj), & 240 !! Arrays for radiative East OBC 241 uebnd(jpj,jpk,3,3), vebnd(jpj,jpk,3,3) , & 242 tebnd(jpj,jpk,2,2), sebnd(jpj,jpk,2,2), & 243 u_cxebnd(jpj,jpk), v_cxebnd(jpj,jpk), & 244 uemsk(jpj,jpk), vemsk(jpj,jpk), temsk(jpj,jpk), & 245 !! West open boundary 246 sshfow(jpjwd:jpjwf), ubtfow(jpjwd:jpjwf), vbtfow(jpjwd:jpjwf), & 247 ufow(jpj,jpk), vfow(jpj,jpk), tfow(jpj,jpk), & 248 sfow(jpj,jpk), ucliw(jpj,jpk), sshfow_b(jpjwd:jpjwf,jpj), & 249 !! Arrays for radiative West OBC 250 uwbnd(jpj,jpk,3,3), vwbnd(jpj,jpk,3,3), & 251 twbnd(jpj,jpk,2,2), swbnd(jpj,jpk,2,2), & 252 u_cxwbnd(jpj,jpk), v_cxwbnd(jpj,jpk), & 253 uwmsk(jpj,jpk), vwmsk(jpj,jpk), twmsk(jpj,jpk), & 254 !! North open boundary 255 sshfon(jpind:jpinf), ubtfon(jpind:jpinf), vbtfon(jpind:jpinf), & 256 ufon(jpi,jpk), vfon(jpi,jpk), tfon(jpi,jpk), & 257 sfon(jpi,jpk), vclin(jpi,jpk), sshfon_b(jpind:jpinf,jpj), & 258 !! Arrays for radiative North OBC 259 unbnd(jpi,jpk,3,3), vnbnd(jpi,jpk,3,3), & 260 tnbnd(jpi,jpk,2,2), snbnd(jpi,jpk,2,2), & 261 u_cynbnd(jpi,jpk), v_cynbnd(jpi,jpk), & 262 unmsk(jpi,jpk), vnmsk(jpi,jpk), tnmsk (jpi,jpk), & 263 !! South open boundary 264 sshfos(jpisd:jpisf), ubtfos(jpisd:jpisf), vbtfos(jpisd:jpisf), & 265 ufos(jpi,jpk), vfos(jpi,jpk), tfos(jpi,jpk), & 266 sfos(jpi,jpk), vclis(jpi,jpk), & 267 sshfos_b(jpisd:jpisf,jpj), & 268 !! Arrays for radiative South OBC 269 usbnd(jpi,jpk,3,3), vsbnd(jpi,jpk,3,3), & 270 tsbnd(jpi,jpk,2,2), ssbnd(jpi,jpk,2,2), & 271 u_cysbnd(jpi,jpk), v_cysbnd(jpi,jpk), & 272 usmsk(jpi,jpk), vsmsk(jpi,jpk), tsmsk(jpi,jpk), & 273 !! 274 STAT=obc_oce_alloc ) 111 ! 112 ALLOCATE( obctmask(jpi,jpj) , obcumask(jpi,jpj), obcvmask(jpi,jpj), & 113 & STAT=obc_oce_alloc ) 114 ! 115 IF( lk_mpp ) CALL mpp_sum ( obc_oce_alloc ) 116 IF( obc_oce_alloc /= 0 ) CALL ctl_warn('obc_oce_alloc: failed to allocate arrays.') 275 117 ! 276 118 END FUNCTION obc_oce_alloc 277 119 278 120 #else 279 121 !!---------------------------------------------------------------------- 280 !! D efault option Empty module No OBC122 !! Dummy module NO Unstructured Open Boundary Condition 281 123 !!---------------------------------------------------------------------- 124 LOGICAL :: ln_tides = .false. !: =T apply tidal harmonic forcing along open boundaries 282 125 #endif 283 126 284 127 !!====================================================================== 285 128 END MODULE obc_oce 129 -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obc_par.F90
r2715 r2797 1 1 MODULE obc_par 2 !!====================================================================== ========3 !! *** MODULE obc_par ***4 !! Open Boundary Cond. : define related parameters5 !!====================================================================== ========6 !! history : OPA ! 1991-01 (CLIPPER) Original code7 !! NEMO 1.0 ! 2002-04 (C. Talandier) modules8 !! - ! 2004/06 (F. Durand) jptobc is defined as a parameter2 !!====================================================================== 3 !! *** MODULE obc_par *** 4 !! Unstructured Open Boundary Cond. : define related parameters 5 !!====================================================================== 6 !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code 7 !! 3.0 ! 2008-04 (NEMO team) add in the reference version 8 !! 3.3 ! 2010-09 (D. Storkey and E. O'Dea) update for Shelf configurations 9 9 !!---------------------------------------------------------------------- 10 #if defined key_obc10 #if defined key_obc 11 11 !!---------------------------------------------------------------------- 12 !! 'key_obc' : 12 !! 'key_obc' : Unstructured Open Boundary Condition 13 13 !!---------------------------------------------------------------------- 14 USE par_oce ! ocean parameters15 14 16 15 IMPLICIT NONE 17 16 PUBLIC 18 17 19 #if ! defined key_agrif 20 LOGICAL, PUBLIC, PARAMETER :: lk_obc = .TRUE. !: Ocean Boundary Condition flag 21 #else 22 LOGICAL, PUBLIC :: lk_obc = .TRUE. !: Ocean Boundary Condition flag 23 #endif 18 LOGICAL, PUBLIC, PARAMETER :: lk_obc = .TRUE. !: Unstructured Ocean Boundary Condition flag 19 INTEGER, PUBLIC, PARAMETER :: jp_obc = 10 !: Maximum number of obc sets 20 INTEGER, PUBLIC, PARAMETER :: jpbtime = 1000 !: Max number of time dumps per file 21 INTEGER, PUBLIC, PARAMETER :: jpbgrd = 3 !: Number of horizontal grid types used (T, U, V) 24 22 25 # if defined key_eel_r5 26 !!---------------------------------------------------------------------- 27 !! 'key_eel_r5' : EEL R5 configuration 28 !!---------------------------------------------------------------------- 29 # include "obc_par_EEL_R5.h90" 30 31 # elif defined key_pomme_r025 32 !!---------------------------------------------------------------------- 33 !! 'key_pomme_r025' : POMME R025 configuration 34 !!---------------------------------------------------------------------- 35 # include "obc_par_POMME_R025.h90" 36 37 # else 38 !!--------------------------------------------------------------------- 39 !! open boundary parameter 40 !!--------------------------------------------------------------------- 41 INTEGER, PARAMETER :: jptobc = 2 !: time dimension of the BCS fields on input 42 43 !! * EAST open boundary 44 LOGICAL, PARAMETER :: lp_obc_east = .FALSE. !: to active or not the East open boundary 45 INTEGER & 46 #if !defined key_agrif 47 , PARAMETER & 48 #endif 49 :: & 50 jpieob = jpiglo-2, & !: i-localization of the East open boundary (must be ocean U-point) 51 jpjed = 2, & !: j-starting indice of the East open boundary (must be land T-point) 52 jpjef = jpjglo-1, & !: j-ending indice of the East open boundary (must be land T-point) 53 jpjedp1 = jpjed+1, & !: first ocean point " " 54 jpjefm1 = jpjef-1 !: last ocean point " " 55 56 !! * WEST open boundary 57 LOGICAL, PARAMETER :: lp_obc_west = .FALSE. !: to active or not the West open boundary 58 INTEGER & 59 #if !defined key_agrif 60 , PARAMETER & 61 #endif 62 :: & 63 jpiwob = 2, & !: i-localization of the West open boundary (must be ocean U-point) 64 jpjwd = 2, & !: j-starting indice of the West open boundary (must be land T-point) 65 jpjwf = jpjglo-1, & !: j-ending indice of the West open boundary (must be land T-point) 66 jpjwdp1 = jpjwd+1, & !: first ocean point " " 67 jpjwfm1 = jpjwf-1 !: last ocean point " " 68 69 !! * NORTH open boundary 70 LOGICAL, PARAMETER :: lp_obc_north = .FALSE. !: to active or not the North open boundary 71 INTEGER & 72 #if !defined key_agrif 73 , PARAMETER & 74 #endif 75 :: & 76 jpjnob = jpjglo-2, & !: j-localization of the North open boundary (must be ocean V-point) 77 jpind = 2, & !: i-starting indice of the North open boundary (must be land T-point) 78 jpinf = jpiglo-1, & !: i-ending indice of the North open boundary (must be land T-point) 79 jpindp1 = jpind+1, & !: first ocean point " " 80 jpinfm1 = jpinf-1 !: last ocean point " " 81 82 !! * SOUTH open boundary 83 LOGICAL, PARAMETER :: lp_obc_south = .FALSE. !: to active or not the South open boundary 84 INTEGER & 85 #if !defined key_agrif 86 , PARAMETER & 87 #endif 88 :: & 89 jpjsob = 2, & !: j-localization of the South open boundary (must be ocean V-point) 90 jpisd = 2, & !: i-starting indice of the South open boundary (must be land T-point) 91 jpisf = jpiglo-1, & !: i-ending indice of the South open boundary (must be land T-point) 92 jpisdp1 = jpisd+1, & !: first ocean point " " 93 jpisfm1 = jpisf-1 !: last ocean point " " 94 95 INTEGER, PARAMETER :: jpnic = 2700 !: maximum number of isolated coastlines points 96 97 # endif 98 23 !! Flags for choice of schemes 24 INTEGER, PUBLIC, PARAMETER :: jp_none = 0 !: Flag for no open boundary condition 25 INTEGER, PUBLIC, PARAMETER :: jp_frs = 1 !: Flag for Flow Relaxation Scheme 26 INTEGER, PUBLIC, PARAMETER :: jp_flather = 2 !: Flag for Flather 99 27 #else 100 28 !!---------------------------------------------------------------------- 101 !! Default option : NOopen boundary condition29 !! Default option : NO Unstructured open boundary condition 102 30 !!---------------------------------------------------------------------- 103 LOGICAL, PUBLIC, PARAMETER :: lk_obc = .FALSE. !:Ocean Boundary Condition flag31 LOGICAL, PUBLIC, PARAMETER :: lk_obc = .FALSE. !: Unstructured Ocean Boundary Condition flag 104 32 #endif 105 33 … … 107 35 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 108 36 !! $Id$ 109 !! Software governed by the CeCILL licence 37 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 110 38 !!====================================================================== 111 39 END MODULE obc_par -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcdta.F90
r2722 r2797 1 1 MODULE obcdta 2 !!============================================================================== 3 !! *** MODULE obcdta *** 4 !! Open boundary data : read the data for the open boundaries. 5 !!============================================================================== 6 !! History : OPA ! 1998-05 (J.M. Molines) Original code 7 !! 8.5 ! 2002-10 (C. Talandier, A-M. Treguier) Free surface, F90 8 !! NEMO 1.0 ! 2004-06 (F. Durand, A-M. Treguier) Netcdf BC files on input 9 !! 3.0 ! 2007-2008 (C. Langlais, P. Mathiot, J.M. Molines) high frequency boundaries data 10 !!------------------------------------------------------------------------------ 2 !!====================================================================== 3 !! *** MODULE obcdta *** 4 !! Open boundary data : read the data for the unstructured open boundaries. 5 !!====================================================================== 6 !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code 7 !! - ! 2007-01 (D. Storkey) Update to use IOM module 8 !! - ! 2007-07 (D. Storkey) add obc_dta_fla 9 !! 3.0 ! 2008-04 (NEMO team) add in the reference version 10 !! 3.3 ! 2010-09 (E.O'Dea) modifications for Shelf configurations 11 !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions 12 !! 3.4 ???????????????? 13 !!---------------------------------------------------------------------- 11 14 #if defined key_obc 12 !!------------------------------------------------------------------------------ 13 !! 'key_obc' : Open Boundary Conditions 14 !!------------------------------------------------------------------------------ 15 !! obc_dta : read u, v, t, s data along each open boundary 16 !!------------------------------------------------------------------------------ 17 USE oce ! ocean dynamics and tracers 15 !!---------------------------------------------------------------------- 16 !! 'key_obc' Open Boundary Conditions 17 !!---------------------------------------------------------------------- 18 !! obc_dta : read external data along open boundaries from file 19 !! obc_dta_init : initialise arrays etc for reading of external data 20 !!---------------------------------------------------------------------- 21 USE oce ! ocean dynamics and tracers 18 22 USE dom_oce ! ocean space and time domain 19 USE lbclnk ! ocean lateral boundary conditions (or mpp link)20 23 USE phycst ! physical constants 21 USE obc_par ! ocean open boundary conditions22 24 USE obc_oce ! ocean open boundary conditions 25 USE obctides ! tidal forcing at boundaries 26 USE fldread ! read input fields 27 USE iom ! IOM library 23 28 USE in_out_manager ! I/O logical units 24 USE lib_mpp ! distributed memory computing 25 USE dynspg_oce ! ocean: surface pressure gradient 26 USE ioipsl ! now only for ymds2ju function 27 USE iom ! 29 #if defined key_lim2 30 USE ice_2 31 #endif 28 32 29 33 IMPLICIT NONE 30 34 PRIVATE 31 35 32 PUBLIC obc_dta ! routine called by step.F90 33 PUBLIC obc_dta_bt ! routine called by dynspg_ts.F90 34 PUBLIC obc_dta_alloc ! function called by obcini.F90 35 36 REAL(wp), DIMENSION(2) :: zjcnes_obc ! 37 REAL(wp), DIMENSION(:), ALLOCATABLE :: ztcobc 38 REAL(wp) :: rdt_obc 39 REAL(wp) :: zjcnes 40 INTEGER :: imm0, iyy0, idd0, iyy, imm, idd 41 INTEGER :: nt_a=2, nt_b=1, itobc, ndate0_cnes, nday_year0 42 INTEGER :: itobce, itobcw, itobcs, itobcn, itobc_b ! number of time steps in OBC files 43 44 INTEGER :: ntobc ! where we are in the obc file 45 INTEGER :: ntobc_b ! first record used 46 INTEGER :: ntobc_a ! second record used 47 48 CHARACTER (len=40) :: cl_obc_eTS, cl_obc_eU ! name of data files 49 CHARACTER (len=40) :: cl_obc_wTS, cl_obc_wU ! - - 50 CHARACTER (len=40) :: cl_obc_nTS, cl_obc_nV ! - - 51 CHARACTER (len=40) :: cl_obc_sTS, cl_obc_sV ! - - 52 53 ! bt arrays for interpolating time dependent data on the boundaries 54 INTEGER :: nt_m=0, ntobc_m 55 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubtedta, vbtedta, sshedta ! East 56 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubtwdta, vbtwdta, sshwdta ! West 57 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubtndta, vbtndta, sshndta ! North 58 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubtsdta, vbtsdta, sshsdta ! South 59 ! arrays used for interpolating time dependent data on the boundaries 60 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uedta, vedta, tedta, sedta ! East 61 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uwdta, vwdta, twdta, swdta ! West 62 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: undta, vndta, tndta, sndta ! North 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: usdta, vsdta, tsdta, ssdta ! South 64 65 ! Masks set to .TRUE. after successful allocation below 66 LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:) :: ltemsk, luemsk, lvemsk ! boolean msks 67 LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:) :: ltwmsk, luwmsk, lvwmsk ! used for outliers 68 LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:) :: ltnmsk, lunmsk, lvnmsk ! checks 69 LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:) :: ltsmsk, lusmsk, lvsmsk 70 71 !! * Substitutions 72 # include "obc_vectopt_loop_substitute.h90" 73 # include "domzgr_substitute.h90" 36 PUBLIC obc_dta ! routine called by step.F90 and dynspg_ts.F90 37 PUBLIC obc_dta_init ! routine called by nemogcm.F90 38 39 INTEGER, ALLOCATABLE, DIMENSION(:) :: nb_obc_fld ! Number of fields to update for each boundary set. 40 INTEGER :: nb_obc_fld_sum ! Total number of fields to update for all boundary sets. 41 42 TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:), TARGET :: bf ! structure of input fields (file informations, fields read) 43 44 TYPE(MAP_POINTER), ALLOCATABLE, DIMENSION(:) :: nbmap_ptr ! array of pointers to nbmap 45 74 46 !!---------------------------------------------------------------------- 75 47 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 76 !! $Id$ 77 !! Software governed by the CeCILL licence 48 !! $Id$ 49 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 78 50 !!---------------------------------------------------------------------- 79 51 CONTAINS 80 52 81 INTEGER FUNCTION obc_dta_alloc() 82 !!------------------------------------------------------------------- 83 !! *** ROUTINE obc_dta_alloc *** 84 !!------------------------------------------------------------------- 85 INTEGER :: ierr(2) 86 !!------------------------------------------------------------------- 87 # if defined key_dynspg_ts 88 ALLOCATE( & ! time-splitting : 0:jptobc 89 ! bt arrays for interpolating time dependent data on the boundaries 90 & ubtedta (jpj,0:jptobc) , vbtedta (jpj,0:jptobc) , sshedta (jpj,0:jptobc) , & 91 & ubtwdta (jpj,0:jptobc) , vbtwdta (jpj,0:jptobc) , sshwdta (jpj,0:jptobc) , & 92 & ubtndta (jpi,0:jptobc) , vbtndta (jpi,0:jptobc) , sshndta (jpi,0:jptobc) , & 93 & ubtsdta (jpi,0:jptobc) , vbtsdta (jpi,0:jptobc) , sshsdta (jpi,0:jptobc) , & 94 ! arrays used for interpolating time dependent data on the boundaries 95 & uedta(jpj,jpk,0:jptobc) , vedta(jpj,jpk,0:jptobc) , & 96 & tedta(jpj,jpk,0:jptobc) , sedta(jpj,jpk,0:jptobc) , & 97 & uwdta(jpj,jpk,0:jptobc) , vwdta(jpj,jpk,0:jptobc) , & 98 & twdta(jpj,jpk,0:jptobc) , swdta(jpj,jpk,0:jptobc) , & 99 & undta(jpi,jpk,0:jptobc) , vndta(jpi,jpk,0:jptobc) , & 100 & tndta(jpi,jpk,0:jptobc) , sndta(jpi,jpk,0:jptobc) , & 101 & usdta(jpi,jpk,0:jptobc) , vsdta(jpi,jpk,0:jptobc) , & 102 & tsdta(jpi,jpk,0:jptobc) , ssdta(jpi,jpk,0:jptobc) , STAT=ierr(1) ) 103 # else 104 ALLOCATE( & ! no time splitting : 1:jptobc 105 ! bt arrays for interpolating time dependent data on the boundaries 106 & ubtedta (jpj,jptobc) , vbtedta (jpj,jptobc) , sshedta (jpj,jptobc) , & 107 & ubtwdta (jpj,jptobc) , vbtwdta (jpj,jptobc) , sshwdta (jpj,jptobc) , & 108 & ubtndta (jpi,jptobc) , vbtndta (jpi,jptobc) , sshndta (jpi,jptobc) , & 109 & ubtsdta (jpi,jptobc) , vbtsdta (jpi,jptobc) , sshsdta (jpi,jptobc) , & 110 ! arrays used for interpolating time dependent data on the boundaries 111 & uedta(jpj,jpk,jptobc) , vedta(jpj,jpk,jptobc) , & 112 & tedta(jpj,jpk,jptobc) , sedta(jpj,jpk,jptobc) , & 113 & uwdta(jpj,jpk,jptobc) , vwdta(jpj,jpk,jptobc) , & 114 & twdta(jpj,jpk,jptobc) , swdta(jpj,jpk,jptobc) , & 115 & undta(jpi,jpk,jptobc) , vndta(jpi,jpk,jptobc) , & 116 & tndta(jpi,jpk,jptobc) , sndta(jpi,jpk,jptobc) , & 117 & usdta(jpi,jpk,jptobc) , vsdta(jpi,jpk,jptobc) , & 118 & tsdta(jpi,jpk,jptobc) , ssdta(jpi,jpk,jptobc) , STAT=ierr(1) ) 119 # endif 120 121 ALLOCATE( ltemsk(jpj,jpk) , luemsk(jpj,jpk) , lvemsk(jpj,jpk) , & 122 & ltwmsk(jpj,jpk) , luwmsk(jpj,jpk) , lvwmsk(jpj,jpk) , & 123 & ltnmsk(jpj,jpk) , lunmsk(jpj,jpk) , lvnmsk(jpj,jpk) , & 124 & ltsmsk(jpj,jpk) , lusmsk(jpj,jpk) , lvsmsk(jpj,jpk) , STAT=ierr(2) ) 125 126 obc_dta_alloc = MAXVAL( ierr ) 127 IF( lk_mpp ) CALL mpp_sum( obc_dta_alloc ) 128 129 IF( obc_dta_alloc == 0 ) THEN ! Initialise mask values following successful allocation 130 ! east ! west ! north ! south ! 131 ltemsk(:,:) = .TRUE. ; ltwmsk(:,:) = .TRUE. ; ltnmsk(:,:) = .TRUE. ; ltsmsk(:,:) = .TRUE. 132 luemsk(:,:) = .TRUE. ; luwmsk(:,:) = .TRUE. ; lunmsk(:,:) = .TRUE. ; lusmsk(:,:) = .TRUE. 133 lvemsk(:,:) = .TRUE. ; lvwmsk(:,:) = .TRUE. ; lvnmsk(:,:) = .TRUE. ; lvsmsk(:,:) = .TRUE. 134 END IF 135 ! 136 END FUNCTION obc_dta_alloc 137 138 139 SUBROUTINE obc_dta( kt ) 140 !!--------------------------------------------------------------------------- 141 !! *** SUBROUTINE obc_dta *** 53 SUBROUTINE obc_dta( kt, jit ) 54 !!---------------------------------------------------------------------- 55 !! *** SUBROUTINE obc_dta *** 142 56 !! 143 !! ** Purpose : Find the climatological boundary arrays for the specified date, 144 !! The boundary arrays are netcdf files. Three possible cases: 145 !! - one time frame only in the file (time dimension = 1). 146 !! in that case the boundary data does not change in time. 147 !! - many time frames. In that case, if we have 12 frames 148 !! we assume monthly fields. 149 !! Else, we assume that time_counter is in seconds 150 !! since the beginning of either the current year or a reference 151 !! year given in the namelist. 152 !! (no check is done so far but one would have to check the "unit" 153 !! attribute of variable time_counter). 57 !! ** Purpose : Update external data for open boundary conditions 58 !! 59 !! ** Method : Use fldread.F90 60 !! 61 !!---------------------------------------------------------------------- 62 INTEGER, INTENT( in ) :: kt ! ocean time-step index 63 INTEGER, INTENT( in ), OPTIONAL :: jit ! subcycle time-step index (for timesplitting option) 64 !! 65 INTEGER :: ib_obc, jfld, jstart, jend ! local indices 66 INTEGER, POINTER, DIMENSION(:) :: nblen, nblenrim ! short cuts 154 67 !! 155 68 !!--------------------------------------------------------------------------- 156 INTEGER, INTENT( in ) :: kt ! ocean time-step index 157 ! 158 INTEGER, SAVE :: immfile, iyyfile ! 159 INTEGER :: nt ! record indices (incrementation) 160 REAL(wp) :: zsec, zxy, znum, zden ! time interpolation weight 69 70 ! for nn_dtactl = 0, initialise data arrays once for all 71 ! from initial conditions 72 !------------------------------------------------------- 73 IF( kt .eq. 1 .and. .not. PRESENT(jit) ) THEN 74 75 DO ib_obc = 1, nb_obc 76 IF( nn_dtactl(ib_obc) .eq. 0 ) THEN 77 78 !!! TO BE DONE !!! 79 80 ENDIF 81 ENDDO 82 83 ENDIF 84 85 ! for nn_dtactl = 1, update external data from files 86 !--------------------------------------------------- 87 88 jstart = 1 89 DO ib_obc = 1, nb_obc 90 IF( nn_dtactl(ib_obc) .eq. 1 ) THEN 91 92 IF( PRESENT(jit) ) THEN 93 ! Update barotropic boundary conditions only 94 ! jit is optional argument for fld_read 95 IF( nn_dyn2d(ib_obc) .gt. 0 ) THEN 96 jend = jstart + 2 97 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), jit=jit ) 98 ENDIF 99 ELSE 100 jend = jstart + nb_obc_fld(ib_obc) - 1 101 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend ), map=nbmap_ptr(jstart:jend), timeshift=1 ) 102 ENDIF 103 jstart = jend+1 104 105 END IF ! nn_dtactl(ib_obc) = 1 106 END DO ! ib_obc 107 108 END SUBROUTINE obc_dta 109 110 111 SUBROUTINE obc_dta_init 112 !!---------------------------------------------------------------------- 113 !! *** SUBROUTINE obc_dta_init *** 114 !! 115 !! ** Purpose : Initialise arrays for reading of external data 116 !! for open boundary conditions 117 !! 118 !! ** Method : Use fldread.F90 119 !! 120 !!---------------------------------------------------------------------- 121 INTEGER :: ib_obc, jfld, jstart, jend, ierror ! local indices 122 !! 123 CHARACTER(len=100) :: cn_dir ! Root directory for location of data files 124 CHARACTER(len=100), DIMENSION(nb_obc) :: cn_dir_array ! Root directory for location of data files 125 INTEGER :: ilen_global ! Max length required for global obc dta arrays 126 INTEGER, ALLOCATABLE, DIMENSION(:) :: ilen1, ilen3 ! size of 1st and 3rd dimensions of local arrays 127 INTEGER, ALLOCATABLE, DIMENSION(:) :: iobc ! obc set for a particular jfld 128 INTEGER, ALLOCATABLE, DIMENSION(:) :: igrid ! index for grid type (1,2,3 = T,U,V) 129 INTEGER, POINTER, DIMENSION(:) :: nblen, nblenrim ! short cuts 130 TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: blf_i ! array of namelist information structures 131 TYPE(FLD_N) :: bn_tem, bn_sal, bn_u3d, bn_v3d ! 132 TYPE(FLD_N) :: bn_ssh, bn_u2d, bn_v2d ! informations about the fields to be read 133 #if defined key_lim2 134 TYPE(FLD_N) :: bn_frld, bn_hicif, bn_hsnif ! 135 #endif 136 NAMELIST/namobc_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d 137 #if defined key_lim2 138 NAMELIST/namobc_dta/ bn_frld, bn_hicif, bn_hsnif 139 #endif 161 140 !!--------------------------------------------------------------------------- 162 141 163 ! 0. initialisation : 164 ! -------------------- 165 IF ( kt == nit000 ) CALL obc_dta_ini ( kt ) 166 IF ( nobc_dta == 0 ) RETURN ! already done in obc_dta_ini 167 IF ( itobc == 1 ) RETURN ! case of only one time frame in file done in obc_dta_ini 168 169 ! in the following code, we assume that obc data are read from files, with more than 1 time frame in it 170 171 iyyfile=iyy ; immfile = 00 ! set component of the current file name 172 IF ( cffile /= 'annual') immfile = imm ! 173 IF ( ln_obc_clim ) iyyfile = 0000 ! assume that climatological files are labeled y0000 174 175 ! 1. Synchronize time of run with time of data files 176 !--------------------------------------------------- 177 ! nday_year is the day number in the current year ( 1 for 01/01 ) 178 zsec=MOD( (kt-nit000)*rdt - (nday_year - nday_year0 )*rday, rday ) ! number of seconds in the current day 179 IF (ln_obc_clim) THEN 180 zjcnes = nday_year - 1 + zsec/rday 181 ELSE 182 zjcnes = zjcnes + rdt/rday 142 ! Work out how many fields there are to read in and allocate arrays 143 ! ----------------------------------------------------------------- 144 ALLOCATE( nb_obc_fld(nb_obc) ) 145 nb_obc_fld(:) = 0 146 DO ib_obc = 1, nb_obc 147 IF( nn_dtactl(ib_obc) .eq. 1 ) THEN 148 IF( nn_dyn2d(ib_obc) .gt. 0 ) THEN 149 nb_obc_fld(ib_obc) = nb_obc_fld(ib_obc) + 3 150 ENDIF 151 IF( nn_dyn3d(ib_obc) .gt. 0 ) THEN 152 nb_obc_fld(ib_obc) = nb_obc_fld(ib_obc) + 2 153 ENDIF 154 IF( nn_tra(ib_obc) .gt. 0 ) THEN 155 nb_obc_fld(ib_obc) = nb_obc_fld(ib_obc) + 2 156 ENDIF 157 #if defined key_lim2 158 IF( nn_ice_lim2(ib_obc) .gt. 0 ) THEN 159 nb_obc_fld(ib_obc) = nb_obc_fld(ib_obc) + 3 160 ENDIF 161 #endif 162 ENDIF 163 ENDDO 164 165 nb_obc_fld_sum = SUM( nb_obc_fld ) 166 167 ALLOCATE( bf(nb_obc_fld_sum), STAT=ierror ) 168 IF( ierror > 0 ) THEN 169 CALL ctl_stop( 'obc_dta: unable to allocate bf structure' ) ; RETURN 183 170 ENDIF 184 185 ! look for 'before' record number in the current file 186 ntobc = nrecbef () ! this function return the record number for 'before', relative to zjcnes 187 188 IF (MOD(kt-1,10)==0) THEN 189 IF (lwp) WRITE(numout,*) 'kt= ',kt,' zjcnes =', zjcnes,' ndastp =',ndastp, 'mm =',imm 190 END IF 191 192 ! 2. read a new data if necessary 193 !-------------------------------- 194 IF ( ntobc /= ntobc_b ) THEN 195 ! we need to read the 'after' record 196 ! swap working index: 197 # if defined key_dynspg_ts 198 nt=nt_m ; nt_m=nt_b ; nt_b=nt 199 # endif 200 nt=nt_b ; nt_b=nt_a ; nt_a=nt 201 ntobc_b = ntobc 202 203 ! new record number : 204 ntobc_a = ntobc_a + 1 205 206 ! all tricky things related to record number, changing files etc... are managed by obc_read 207 208 CALL obc_read (kt, nt_a, ntobc_a, iyyfile, immfile ) 209 210 ! update zjcnes_obc 211 # if defined key_dynspg_ts 212 ntobc_m=mod(ntobc_b-2+itobc,itobc)+1 213 zjcnes_obc(nt_m)= ztcobc(ntobc_m) 214 # endif 215 zjcnes_obc(nt_b)= ztcobc(ntobc_b) 216 zjcnes_obc(nt_a)= ztcobc(ntobc_a) 171 ALLOCATE( blf_i(nb_obc_fld_sum), STAT=ierror ) 172 IF( ierror > 0 ) THEN 173 CALL ctl_stop( 'obc_dta: unable to allocate blf_i structure' ) ; RETURN 217 174 ENDIF 218 219 ! 3. interpolation at each time step 220 ! ------------------------------------ 221 IF( ln_obc_clim) THEN 222 znum= MOD(zjcnes - zjcnes_obc(nt_b), REAL(nyear_len(1),wp) ) 223 IF( znum < 0 ) znum = znum + REAL(nyear_len(1),wp) 224 zden= MOD(zjcnes_obc(nt_a) - zjcnes_obc(nt_b), REAL(nyear_len(1),wp) ) 225 IF( zden < 0 ) zden = zden + REAL(nyear_len(1),wp) 226 ELSE 227 znum= zjcnes - zjcnes_obc(nt_b) 228 zden= zjcnes_obc(nt_a) - zjcnes_obc(nt_b) 175 ALLOCATE( nbmap_ptr(nb_obc_fld_sum), STAT=ierror ) 176 IF( ierror > 0 ) THEN 177 CALL ctl_stop( 'obc_dta: unable to allocate nbmap_ptr structure' ) ; RETURN 229 178 ENDIF 230 zxy = znum / zden 231 232 IF( lp_obc_east ) THEN 233 ! fills sfoe, tfoe, ufoe ,vfoe 234 sfoe(:,:) = zxy * sedta (:,:,nt_a) + (1. - zxy)*sedta(:,:,nt_b) 235 tfoe(:,:) = zxy * tedta (:,:,nt_a) + (1. - zxy)*tedta(:,:,nt_b) 236 ufoe(:,:) = zxy * uedta (:,:,nt_a) + (1. - zxy)*uedta(:,:,nt_b) 237 vfoe(:,:) = zxy * vedta (:,:,nt_a) + (1. - zxy)*vedta(:,:,nt_b) 179 ALLOCATE( ilen1(nb_obc_fld_sum), ilen3(nb_obc_fld_sum) ) 180 ALLOCATE( iobc(nb_obc_fld_sum) ) 181 ALLOCATE( igrid(nb_obc_fld_sum) ) 182 183 ! Read namelists 184 ! -------------- 185 REWIND(numnam) 186 jfld = 0 187 DO ib_obc = 1, nb_obc 188 IF( nn_dtactl(ib_obc) .eq. 1 ) THEN 189 ! set file information 190 cn_dir = './' ! directory in which the model is executed 191 ! ... default values (NB: frequency positive => hours, negative => months) 192 ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! 193 ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! 194 bn_ssh = FLD_N( 'obc_ssh' , 24 , 'sossheig' , .false. , .false. , 'yearly' , '' , '' ) 195 bn_u2d = FLD_N( 'obc_vel2d_u' , 24 , 'vobtcrtx' , .false. , .false. , 'yearly' , '' , '' ) 196 bn_v2d = FLD_N( 'obc_vel2d_v' , 24 , 'vobtcrty' , .false. , .false. , 'yearly' , '' , '' ) 197 bn_u3d = FLD_N( 'obc_vel3d_u' , 24 , 'vozocrtx' , .false. , .false. , 'yearly' , '' , '' ) 198 bn_v3d = FLD_N( 'obc_vel3d_v' , 24 , 'vomecrty' , .false. , .false. , 'yearly' , '' , '' ) 199 bn_tem = FLD_N( 'obc_tem' , 24 , 'votemper' , .false. , .false. , 'yearly' , '' , '' ) 200 bn_sal = FLD_N( 'obc_sal' , 24 , 'vosaline' , .false. , .false. , 'yearly' , '' , '' ) 201 #if defined key_lim2 202 bn_frld = FLD_N( 'obc_frld' , 24 , 'ildsconc' , .false. , .false. , 'yearly' , '' , '' ) 203 bn_hicif = FLD_N( 'obc_hicif' , 24 , 'iicethic' , .false. , .false. , 'yearly' , '' , '' ) 204 bn_hsnif = FLD_N( 'obc_hsnif' , 24 , 'isnothic' , .false. , .false. , 'yearly' , '' , '' ) 205 #endif 206 207 ! Important NOT to rewind here. 208 READ( numnam, namobc_dta ) 209 210 cn_dir_array(ib_obc) = cn_dir 211 212 nblen => idx_obc(ib_obc)%nblen 213 nblenrim => idx_obc(ib_obc)%nblenrim 214 215 ! Only read in necessary fields for this set. 216 ! Important that barotropic variables come first. 217 IF( nn_dyn2d(ib_obc) .gt. 0 ) THEN 218 219 jfld = jfld + 1 220 blf_i(jfld) = bn_ssh 221 iobc(jfld) = ib_obc 222 igrid(jfld) = 1 223 IF( nn_dyn2d(ib_obc) .eq. jp_frs ) THEN 224 ilen1(jfld) = nblen(igrid(jfld)) 225 ELSE 226 ilen1(jfld) = nblenrim(igrid(jfld)) 227 ENDIF 228 ilen3(jfld) = 1 229 230 jfld = jfld + 1 231 blf_i(jfld) = bn_u2d 232 iobc(jfld) = ib_obc 233 igrid(jfld) = 2 234 IF( nn_dyn2d(ib_obc) .eq. jp_frs ) THEN 235 ilen1(jfld) = nblen(igrid(jfld)) 236 ELSE 237 ilen1(jfld) = nblenrim(igrid(jfld)) 238 ENDIF 239 ilen3(jfld) = 1 240 241 jfld = jfld + 1 242 blf_i(jfld) = bn_v2d 243 iobc(jfld) = ib_obc 244 igrid(jfld) = 3 245 IF( nn_dyn2d(ib_obc) .eq. jp_frs ) THEN 246 ilen1(jfld) = nblen(igrid(jfld)) 247 ELSE 248 ilen1(jfld) = nblenrim(igrid(jfld)) 249 ENDIF 250 ilen3(jfld) = 1 251 252 ENDIF 253 254 ! baroclinic velocities 255 IF( nn_dyn3d(ib_obc) .gt. 0 ) THEN 256 257 jfld = jfld + 1 258 blf_i(jfld) = bn_u3d 259 iobc(jfld) = ib_obc 260 igrid(jfld) = 2 261 IF( nn_dyn3d(ib_obc) .eq. jp_frs ) THEN 262 ilen1(jfld) = nblen(igrid(jfld)) 263 ELSE 264 ilen1(jfld) = nblenrim(igrid(jfld)) 265 ENDIF 266 ilen3(jfld) = jpk 267 268 jfld = jfld + 1 269 blf_i(jfld) = bn_v3d 270 iobc(jfld) = ib_obc 271 igrid(jfld) = 3 272 IF( nn_dyn3d(ib_obc) .eq. jp_frs ) THEN 273 ilen1(jfld) = nblen(igrid(jfld)) 274 ELSE 275 ilen1(jfld) = nblenrim(igrid(jfld)) 276 ENDIF 277 ilen3(jfld) = jpk 278 279 ENDIF 280 281 ! temperature and salinity 282 IF( nn_tra(ib_obc) .gt. 0 ) THEN 283 284 jfld = jfld + 1 285 blf_i(jfld) = bn_tem 286 iobc(jfld) = ib_obc 287 igrid(jfld) = 1 288 IF( nn_tra(ib_obc) .eq. jp_frs ) THEN 289 ilen1(jfld) = nblen(igrid(jfld)) 290 ELSE 291 ilen1(jfld) = nblenrim(igrid(jfld)) 292 ENDIF 293 ilen3(jfld) = jpk 294 295 jfld = jfld + 1 296 blf_i(jfld) = bn_sal 297 iobc(jfld) = ib_obc 298 igrid(jfld) = 1 299 IF( nn_tra(ib_obc) .eq. jp_frs ) THEN 300 ilen1(jfld) = nblen(igrid(jfld)) 301 ELSE 302 ilen1(jfld) = nblenrim(igrid(jfld)) 303 ENDIF 304 ilen3(jfld) = jpk 305 306 ENDIF 307 308 #if defined key_lim2 309 ! sea ice 310 IF( nn_tra(ib_obc) .gt. 0 ) THEN 311 312 jfld = jfld + 1 313 blf_i(jfld) = bn_frld 314 iobc(jfld) = ib_obc 315 igrid(jfld) = 1 316 IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN 317 ilen1(jfld) = nblen(igrid(jfld)) 318 ELSE 319 ilen1(jfld) = nblenrim(igrid(jfld)) 320 ENDIF 321 ilen3(jfld) = 1 322 323 jfld = jfld + 1 324 blf_i(jfld) = bn_hicif 325 iobc(jfld) = ib_obc 326 igrid(jfld) = 1 327 IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN 328 ilen1(jfld) = nblen(igrid(jfld)) 329 ELSE 330 ilen1(jfld) = nblenrim(igrid(jfld)) 331 ENDIF 332 ilen3(jfld) = 1 333 334 jfld = jfld + 1 335 blf_i(jfld) = bn_hsnif 336 iobc(jfld) = ib_obc 337 igrid(jfld) = 1 338 IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN 339 ilen1(jfld) = nblen(igrid(jfld)) 340 ELSE 341 ilen1(jfld) = nblenrim(igrid(jfld)) 342 ENDIF 343 ilen3(jfld) = 1 344 345 ENDIF 346 #endif 347 ENDIF ! nn_dtactl .eq. 1 348 ENDDO ! ib_obc 349 350 IF( jfld .ne. nb_obc_fld_sum ) THEN 351 CALL ctl_stop( 'obc_dta: error in initialisation: jpfld .ne. nb_obc_fld_sum' ) ; RETURN 238 352 ENDIF 239 353 240 IF( lp_obc_west) THEN 241 ! fills sfow, tfow, ufow ,vfow 242 sfow(:,:) = zxy * swdta (:,:,nt_a) + (1. - zxy)*swdta(:,:,nt_b) 243 tfow(:,:) = zxy * twdta (:,:,nt_a) + (1. - zxy)*twdta(:,:,nt_b) 244 ufow(:,:) = zxy * uwdta (:,:,nt_a) + (1. - zxy)*uwdta(:,:,nt_b) 245 vfow(:,:) = zxy * vwdta (:,:,nt_a) + (1. - zxy)*vwdta(:,:,nt_b) 246 ENDIF 247 248 IF( lp_obc_north) THEN 249 ! fills sfon, tfon, ufon ,vfon 250 sfon(:,:) = zxy * sndta (:,:,nt_a) + (1. - zxy)*sndta(:,:,nt_b) 251 tfon(:,:) = zxy * tndta (:,:,nt_a) + (1. - zxy)*tndta(:,:,nt_b) 252 ufon(:,:) = zxy * undta (:,:,nt_a) + (1. - zxy)*undta(:,:,nt_b) 253 vfon(:,:) = zxy * vndta (:,:,nt_a) + (1. - zxy)*vndta(:,:,nt_b) 254 ENDIF 255 256 IF( lp_obc_south) THEN 257 ! fills sfos, tfos, ufos ,vfos 258 sfos(:,:) = zxy * ssdta (:,:,nt_a) + (1. - zxy)*ssdta(:,:,nt_b) 259 tfos(:,:) = zxy * tsdta (:,:,nt_a) + (1. - zxy)*tsdta(:,:,nt_b) 260 ufos(:,:) = zxy * usdta (:,:,nt_a) + (1. - zxy)*usdta(:,:,nt_b) 261 vfos(:,:) = zxy * vsdta (:,:,nt_a) + (1. - zxy)*vsdta(:,:,nt_b) 262 ENDIF 354 DO jfld = 1, nb_obc_fld_sum 355 ALLOCATE( bf(jfld)%fnow(ilen1(jfld),1,ilen3(jfld)) ) 356 IF( blf_i(jfld)%ln_tint ) ALLOCATE( bf(jfld)%fdta(ilen1(jfld),1,ilen3(jfld),2) ) 357 nbmap_ptr(jfld)%ptr => idx_obc(iobc(jfld))%nbmap(:,igrid(jfld)) 358 ENDDO 359 360 ! fill bf with blf_i and control print 361 !------------------------------------- 362 jstart = 1 363 DO ib_obc = 1, nb_obc 364 jend = jstart + nb_obc_fld(ib_obc) - 1 365 CALL fld_fill( bf(jstart:jend), blf_i(jstart:jend), cn_dir_array(ib_obc), 'obc_dta', 'open boundary conditions', 'namobc_dta' ) 366 jstart = jend + 1 367 ENDDO 368 369 ! Initialise local boundary data arrays 370 ! nn_dtactl=0 : allocate space - will be filled from initial conditions later 371 ! nn_dtactl=1 : point to "fnow" arrays 372 !------------------------------------- 373 374 jfld = 0 375 DO ib_obc=1, nb_obc 376 377 nblen => idx_obc(ib_obc)%nblen 378 nblenrim => idx_obc(ib_obc)%nblenrim 379 380 IF( nn_dtactl(ib_obc) .eq. 0 ) THEN 381 382 ! nn_dtactl = 0 383 ! Allocate space 384 !--------------- 385 IF (nn_dyn2d(ib_obc) .gt. 0) THEN 386 IF( nn_dyn2d(ib_obc) .eq. jp_frs ) THEN 387 ilen1(1) = nblen(1) 388 ilen1(2) = nblen(2) 389 ilen1(3) = nblen(3) 390 ELSE 391 ilen1(1) = nblenrim(1) 392 ilen1(2) = nblenrim(2) 393 ilen1(3) = nblenrim(3) 394 ENDIF 395 ALLOCATE( dta_obc(ib_obc)%ssh(ilen1(1)) ) 396 ALLOCATE( dta_obc(ib_obc)%u2d(ilen1(2)) ) 397 ALLOCATE( dta_obc(ib_obc)%v2d(ilen1(3)) ) 398 ENDIF 399 IF (nn_dyn3d(ib_obc) .gt. 0) THEN 400 IF( nn_dyn3d(ib_obc) .eq. jp_frs ) THEN 401 ilen1(2) = nblen(2) 402 ilen1(3) = nblen(3) 403 ELSE 404 ilen1(2) = nblenrim(2) 405 ilen1(3) = nblenrim(3) 406 ENDIF 407 ALLOCATE( dta_obc(ib_obc)%u3d(ilen1(2),jpk) ) 408 ALLOCATE( dta_obc(ib_obc)%v3d(ilen1(3),jpk) ) 409 ENDIF 410 IF (nn_tra(ib_obc) .gt. 0) THEN 411 IF( nn_tra(ib_obc) .eq. jp_frs ) THEN 412 ilen1(1) = nblen(1) 413 ELSE 414 ilen1(1) = nblenrim(1) 415 ENDIF 416 ALLOCATE( dta_obc(ib_obc)%tem(ilen1(1),jpk) ) 417 ALLOCATE( dta_obc(ib_obc)%sal(ilen1(1),jpk) ) 418 ENDIF 419 #if defined key_lim2 420 IF (nn_ice_lim2(ib_obc) .gt. 0) THEN 421 IF( nn_ice_lim2(ib_obc) .eq. jp_frs ) THEN 422 ilen1(1) = nblen(igrid(jfld)) 423 ELSE 424 ilen1(1) = nblenrim(igrid(jfld)) 425 ENDIF 426 ALLOCATE( dta_obc(ib_obc)%ssh(ilen1(1)) ) 427 ALLOCATE( dta_obc(ib_obc)%u2d(ilen1(1)) ) 428 ALLOCATE( dta_obc(ib_obc)%v2d(ilen1(1)) ) 429 ENDIF 430 #endif 431 432 ELSE 433 434 ! nn_dtactl = 1 435 ! Set boundary data arrays to point to relevant "fnow" arrays 436 !----------------------------------------------------------- 437 IF (nn_dyn2d(ib_obc) .gt. 0) THEN 438 jfld = jfld + 1 439 dta_obc(ib_obc)%ssh => bf(jfld)%fnow(:,1,1) 440 jfld = jfld + 1 441 dta_obc(ib_obc)%u2d => bf(jfld)%fnow(:,1,1) 442 jfld = jfld + 1 443 dta_obc(ib_obc)%v2d => bf(jfld)%fnow(:,1,1) 444 ENDIF 445 IF (nn_dyn3d(ib_obc) .gt. 0) THEN 446 jfld = jfld + 1 447 dta_obc(ib_obc)%u3d => bf(jfld)%fnow(:,1,:) 448 jfld = jfld + 1 449 dta_obc(ib_obc)%v3d => bf(jfld)%fnow(:,1,:) 450 ENDIF 451 IF (nn_tra(ib_obc) .gt. 0) THEN 452 jfld = jfld + 1 453 dta_obc(ib_obc)%tem => bf(jfld)%fnow(:,1,:) 454 jfld = jfld + 1 455 dta_obc(ib_obc)%sal => bf(jfld)%fnow(:,1,:) 456 ENDIF 457 #if defined key_lim2 458 IF (nn_ice_lim2(ib_obc) .gt. 0) THEN 459 jfld = jfld + 1 460 dta_obc(ib_obc)%frld => bf(jfld)%fnow(:,1,1) 461 jfld = jfld + 1 462 dta_obc(ib_obc)%hicif => bf(jfld)%fnow(:,1,1) 463 jfld = jfld + 1 464 dta_obc(ib_obc)%hsnif => bf(jfld)%fnow(:,1,1) 465 ENDIF 466 #endif 467 468 ENDIF ! nn_dtactl .eq. 0 469 470 ENDDO ! ib_obc 471 472 END SUBROUTINE obc_dta_init 473 474 #else 475 !!---------------------------------------------------------------------- 476 !! Dummy module NO Open Boundary Conditions 477 !!---------------------------------------------------------------------- 478 CONTAINS 479 SUBROUTINE obc_dta( kt, jit ) ! Empty routine 480 WRITE(*,*) 'obc_dta: You should not have seen this print! error?', kt 263 481 END SUBROUTINE obc_dta 264 265 266 SUBROUTINE obc_dta_ini( kt ) 267 !!----------------------------------------------------------------------------- 268 !! *** SUBROUTINE obc_dta_ini *** 269 !! 270 !! ** Purpose : When obc_dta first call, realize some data initialization 271 !!---------------------------------------------------------------------------- 272 INTEGER, INTENT(in) :: kt ! ocean time-step index 273 ! 274 INTEGER :: ji, jj ! dummy loop indices 275 INTEGER, SAVE :: immfile, iyyfile ! 276 277 ! variables for the julian day calculation 278 INTEGER :: iyear, imonth, iday 279 REAL(wp) :: zsec , zjulian, zjuliancnes 280 281 IF(lwp) WRITE(numout,*) 282 IF(lwp) WRITE(numout,*) 'obc_dta : find boundary data' 283 IF(lwp) WRITE(numout,*) '~~~~~~~' 284 IF (lwp) THEN 285 IF ( nobc_dta == 0 ) THEN 286 WRITE(numout,*) ' OBC data taken from initial conditions.' 287 ELSE 288 WRITE(numout,*) ' OBC data taken from netcdf files.' 289 ENDIF 290 ENDIF 291 nday_year0 = nday_year ! to remember the day when kt=nit000 292 293 sedta(:,:,:) = 0.e0 ; tedta(:,:,:) = 0.e0 ; uedta(:,:,:) = 0.e0 ; vedta(:,:,:) = 0.e0 ! East 294 swdta(:,:,:) = 0.e0 ; twdta(:,:,:) = 0.e0 ; uwdta(:,:,:) = 0.e0 ; vwdta(:,:,:) = 0.e0 ! West 295 sndta(:,:,:) = 0.e0 ; tndta(:,:,:) = 0.e0 ; undta(:,:,:) = 0.e0 ; vndta(:,:,:) = 0.e0 ! North 296 ssdta(:,:,:) = 0.e0 ; tsdta(:,:,:) = 0.e0 ; usdta(:,:,:) = 0.e0 ; vsdta(:,:,:) = 0.e0 ! South 297 298 sfoe(:,:) = 0.e0 ; tfoe(:,:) = 0.e0 ; ufoe(:,:) = 0.e0 ; vfoe(:,:) = 0.e0 ! East 299 sfow(:,:) = 0.e0 ; tfow(:,:) = 0.e0 ; ufow(:,:) = 0.e0 ; vfow(:,:) = 0.e0 ! West 300 sfon(:,:) = 0.e0 ; tfon(:,:) = 0.e0 ; ufon(:,:) = 0.e0 ; vfon(:,:) = 0.e0 ! North 301 sfos(:,:) = 0.e0 ; tfos(:,:) = 0.e0 ; ufos(:,:) = 0.e0 ; vfos(:,:) = 0.e0 ! South 302 303 IF (nobc_dta == 0 ) THEN ! boundary data are the initial data of this run (set only at nit000) 304 IF (lp_obc_east) THEN ! East 305 DO ji = nie0 , nie1 306 sfoe(nje0:nje1,:) = temsk(nje0:nje1,:) * sn (ji+1 , nje0:nje1 , :) * tmask(ji+1,nje0:nje1 , :) 307 tfoe(nje0:nje1,:) = temsk(nje0:nje1,:) * tn (ji+1 , nje0:nje1 , :) * tmask(ji+1,nje0:nje1 , :) 308 ufoe(nje0:nje1,:) = uemsk(nje0:nje1,:) * un (ji , nje0:nje1 , :) * umask(ji, nje0:nje1 , :) 309 vfoe(nje0:nje1,:) = vemsk(nje0:nje1,:) * vn (ji+1 , nje0:nje1 , :) * vmask(ji+1,nje0:nje1 , :) 310 END DO 311 ENDIF 312 313 IF (lp_obc_west) THEN ! West 314 DO ji = niw0 , niw1 315 sfow(njw0:njw1,:) = twmsk(njw0:njw1,:) * sn (ji , njw0:njw1 , :) * tmask(ji , njw0:njw1 , :) 316 tfow(njw0:njw1,:) = twmsk(njw0:njw1,:) * tn (ji , njw0:njw1 , :) * tmask(ji , njw0:njw1 , :) 317 ufow(njw0:njw1,:) = uwmsk(njw0:njw1,:) * un (ji , njw0:njw1 , :) * umask(ji , njw0:njw1 , :) 318 vfow(njw0:njw1,:) = vwmsk(njw0:njw1,:) * vn (ji , njw0:njw1 , :) * vmask(ji , njw0:njw1 , :) 319 END DO 320 ENDIF 321 322 IF (lp_obc_north) THEN ! North 323 DO jj = njn0 , njn1 324 sfon(nin0:nin1,:) = tnmsk(nin0:nin1,:) * sn (nin0:nin1 , jj+1 , :) * tmask(nin0:nin1 , jj+1 , :) 325 tfon(nin0:nin1,:) = tnmsk(nin0:nin1,:) * tn (nin0:nin1 , jj+1 , :) * tmask(nin0:nin1 , jj+1 , :) 326 ufon(nin0:nin1,:) = unmsk(nin0:nin1,:) * un (nin0:nin1 , jj+1 , :) * umask(nin0:nin1 , jj+1 , :) 327 vfon(nin0:nin1,:) = vnmsk(nin0:nin1,:) * vn (nin0:nin1 , jj , :) * vmask(nin0:nin1 , jj , :) 328 END DO 329 ENDIF 330 331 IF (lp_obc_south) THEN ! South 332 DO jj = njs0 , njs1 333 sfos(nis0:nis1,:) = tsmsk(nis0:nis1,:) * sn (nis0:nis1 , jj , :) * tmask(nis0:nis1 , jj , :) 334 tfos(nis0:nis1,:) = tsmsk(nis0:nis1,:) * tn (nis0:nis1 , jj , :) * tmask(nis0:nis1 , jj , :) 335 ufos(nis0:nis1,:) = usmsk(nis0:nis1,:) * un (nis0:nis1 , jj , :) * umask(nis0:nis1 , jj , :) 336 vfos(nis0:nis1,:) = vsmsk(nis0:nis1,:) * vn (nis0:nis1 , jj , :) * vmask(nis0:nis1 , jj , :) 337 END DO 338 ENDIF 339 RETURN ! exit the routine all is done 340 ENDIF ! nobc_dta = 0 341 342 !!!! In the following OBC data are read from files. 343 ! all logical-mask are initialzed to true when declared 344 WHERE ( temsk == 0 ) ltemsk=.FALSE. 345 WHERE ( uemsk == 0 ) luemsk=.FALSE. 346 WHERE ( vemsk == 0 ) lvemsk=.FALSE. 347 348 WHERE ( twmsk == 0 ) ltwmsk=.FALSE. 349 WHERE ( uwmsk == 0 ) luwmsk=.FALSE. 350 WHERE ( vwmsk == 0 ) lvwmsk=.FALSE. 351 352 WHERE ( tnmsk == 0 ) ltnmsk=.FALSE. 353 WHERE ( unmsk == 0 ) lunmsk=.FALSE. 354 WHERE ( vnmsk == 0 ) lvnmsk=.FALSE. 355 356 WHERE ( tsmsk == 0 ) ltsmsk=.FALSE. 357 WHERE ( usmsk == 0 ) lusmsk=.FALSE. 358 WHERE ( vsmsk == 0 ) lvsmsk=.FALSE. 359 360 iyear=1950; imonth=01; iday=01; zsec=0. 361 ! zjuliancnes : julian day corresonding to 01/01/1950 362 CALL ymds2ju(iyear, imonth, iday,zsec , zjuliancnes) 363 364 !current year and curent month 365 iyy=INT(ndastp/10000) ; imm=INT((ndastp -iyy*10000)/100) ; idd=(ndastp-iyy*10000-imm*100) 366 IF (iyy < 1900) iyy = iyy+1900 ! always assume that years are on 4 digits. 367 CALL ymds2ju(iyy, imm, idd ,zsec , zjulian) 368 ndate0_cnes = zjulian - zjuliancnes ! jcnes day when call to obc_dta_ini 369 370 iyyfile=iyy ; immfile=0 ! set component of the current file name 371 IF ( cffile /= 'annual') immfile=imm 372 IF ( ln_obc_clim) iyyfile = 0 ! assume that climatological files are labeled y0000 373 374 CALL obc_dta_chktime ( iyyfile, immfile ) 375 376 IF ( itobc == 1 ) THEN 377 ! in this case we will provide boundary data only once. 378 nt_a=1 ; ntobc_a=1 379 CALL obc_read (nit000, nt_a, ntobc_a, iyyfile, immfile) 380 IF( lp_obc_east ) THEN 381 ! fills sfoe, tfoe, ufoe ,vfoe 382 sfoe(:,:) = sedta (:,:,1) ; tfoe(:,:) = tedta (:,:,1) 383 ufoe(:,:) = uedta (:,:,1) ; vfoe(:,:) = vedta (:,:,1) 384 ENDIF 385 386 IF( lp_obc_west) THEN 387 ! fills sfow, tfow, ufow ,vfow 388 sfow(:,:) = swdta (:,:,1) ; tfow(:,:) = twdta (:,:,1) 389 ufow(:,:) = uwdta (:,:,1) ; vfow(:,:) = vwdta (:,:,1) 390 ENDIF 391 392 IF( lp_obc_north) THEN 393 ! fills sfon, tfon, ufon ,vfon 394 sfon(:,:) = sndta (:,:,1) ; tfon(:,:) = tndta (:,:,1) 395 ufon(:,:) = undta (:,:,1) ; vfon(:,:) = vndta (:,:,1) 396 ENDIF 397 398 IF( lp_obc_south) THEN 399 ! fills sfos, tfos, ufos ,vfos 400 sfos(:,:) = ssdta (:,:,1) ; tfos(:,:) = tsdta (:,:,1) 401 ufos(:,:) = usdta (:,:,1) ; vfos(:,:) = vsdta (:,:,1) 402 ENDIF 403 RETURN ! we go out of obc_dta_ini -------------------------------------->>>>> 404 ENDIF 405 406 ! nday_year is the day number in the current year ( 1 for 01/01 ) 407 ! we suppose that we always start from the begining of a day 408 ! zsec=MOD( (kt-nit000)*rdt - (nday_year - nday_year0 )*rday, rday ) ! number of seconds in the current day 409 zsec=0.e0 ! here, kt=nit000, nday_year = ndat_year0 410 411 IF (ln_obc_clim) THEN 412 zjcnes = nday_year - 1 + zsec/rday ! for clim file time is in days in a year 413 ELSE 414 zjcnes = ndate0_cnes + (nday_year - nday_year0 ) + zsec/rday 415 ENDIF 416 417 ! look for 'before' record number in the current file 418 ntobc = nrecbef () 419 420 IF (lwp) WRITE(numout,*) 'obc files frequency :',cffile 421 IF (lwp) WRITE(numout,*) ' zjcnes0 =',zjcnes,' ndastp0 =',ndastp 422 IF (lwp) WRITE(numout,*) ' annee0 ',iyy,' month0 ', imm,' day0 ', idd 423 IF (lwp) WRITE(numout,*) 'first file open :',cl_obc_nTS 424 425 ! record initialisation 426 !-------------------- 427 nt_b = 1 ; nt_a = 2 428 429 ntobc_a = ntobc + 1 430 ntobc_b = ntobc 431 432 CALL obc_read (kt, nt_b, ntobc_b, iyyfile, immfile) ! read 'before' fields 433 CALL obc_read (kt, nt_a, ntobc_a, iyyfile, immfile) ! read 'after' fields 434 435 ! additional frame in case of time-splitting 436 # if defined key_dynspg_ts 437 nt_m = 0 438 ntobc_m=mod(ntobc_b-2+itobc,itobc)+1 439 zjcnes_obc(nt_m)= ztcobc(ntobc_m) ! FDbug has not checked that this is correct!! 440 IF (ln_rstart) THEN 441 CALL obc_read (kt, nt_m, ntobc_m, iyyfile, immfile) ! read 'after' fields 442 ENDIF 443 # endif 444 445 zjcnes_obc(nt_b)= ztcobc(ntobc_b) 446 zjcnes_obc(nt_a)= ztcobc(ntobc_a) 447 ! 448 END SUBROUTINE obc_dta_ini 449 450 451 SUBROUTINE obc_dta_chktime (kyyfile, kmmfile) 452 ! 453 ! check the number of time steps in the files and read ztcobc 454 ! 455 ! * Arguments 456 INTEGER, INTENT(in) :: kyyfile, kmmfile 457 ! * local variables 458 INTEGER :: istop ! error control 459 INTEGER :: ji ! dummy loop index 460 461 INTEGER :: idvar, id_e, id_w, id_n, id_s ! file identifiers 462 INTEGER, DIMENSION(1) :: itmp 463 CHARACTER(LEN=25) :: cl_vname 464 465 ntobc_a = 0; itobce =0 ; itobcw = 0; itobcn = 0; itobcs = 0 466 ! build file name 467 IF(ln_obc_clim) THEN ! revert to old convention for climatological OBC forcing 468 cl_obc_eTS='obceast_TS.nc' 469 cl_obc_wTS='obcwest_TS.nc' 470 cl_obc_nTS='obcnorth_TS.nc' 471 cl_obc_sTS='obcsouth_TS.nc' 472 ELSE ! convention for climatological OBC 473 WRITE(cl_obc_eTS ,'("obc_east_TS_y",i4.4,"m",i2.2,".nc")' ) kyyfile,kmmfile 474 WRITE(cl_obc_wTS ,'("obc_west_TS_y",i4.4,"m",i2.2,".nc")' ) kyyfile,kmmfile 475 WRITE(cl_obc_nTS ,'("obc_north_TS_y",i4.4,"m",i2.2,".nc")' ) kyyfile,kmmfile 476 WRITE(cl_obc_sTS ,'("obc_south_TS_y",i4.4,"m",i2.2,".nc")' ) kyyfile,kmmfile 477 ENDIF 478 479 cl_vname = 'time_counter' 480 IF ( lp_obc_east ) THEN 481 CALL iom_open ( cl_obc_eTS , id_e ) 482 idvar = iom_varid( id_e, cl_vname, kdimsz = itmp ); itobce=itmp(1) 483 ENDIF 484 IF ( lp_obc_west ) THEN 485 CALL iom_open ( cl_obc_wTS , id_w ) 486 idvar = iom_varid( id_w, cl_vname, kdimsz = itmp ) ; itobcw=itmp(1) 487 ENDIF 488 IF ( lp_obc_north ) THEN 489 CALL iom_open ( cl_obc_nTS , id_n ) 490 idvar = iom_varid( id_n, cl_vname, kdimsz = itmp ) ; itobcn=itmp(1) 491 ENDIF 492 IF ( lp_obc_south ) THEN 493 CALL iom_open ( cl_obc_sTS , id_s ) 494 idvar = iom_varid( id_s, cl_vname, kdimsz = itmp ) ; itobcs=itmp(1) 495 ENDIF 496 497 itobc = MAX( itobce, itobcw, itobcn, itobcs ) 498 istop = 0 499 IF ( lp_obc_east .AND. itobce /= itobc ) istop = istop+1 500 IF ( lp_obc_west .AND. itobcw /= itobc ) istop = istop+1 501 IF ( lp_obc_north .AND. itobcn /= itobc ) istop = istop+1 502 IF ( lp_obc_south .AND. itobcs /= itobc ) istop = istop+1 503 nstop = nstop + istop 504 505 IF ( istop /= 0 ) THEN 506 WRITE(ctmp1,*) ' east, west, north, south: ', itobce, itobcw, itobcn, itobcs 507 CALL ctl_stop( 'obcdta : all files must have the same number of time steps', ctmp1 ) 508 ENDIF 509 510 IF ( itobc == 1 ) THEN 511 IF (lwp) THEN 512 WRITE(numout,*) ' obcdta found one time step only in the OBC files' 513 IF (ln_obc_clim) THEN 514 ! OK no problem 515 ELSE 516 ln_obc_clim=.true. 517 WRITE(numout,*) ' we force ln_obc_clim to T' 518 ENDIF 519 ENDIF 520 ELSE 521 IF ( ALLOCATED(ztcobc) ) DEALLOCATE ( ztcobc ) 522 ALLOCATE (ztcobc(itobc)) 523 DO ji=1,1 ! use a dummy loop to read ztcobc only once 524 IF ( lp_obc_east ) THEN 525 CALL iom_gettime ( id_e, ztcobc, cl_vname ) ; CALL iom_close (id_e) ; EXIT 526 ENDIF 527 IF ( lp_obc_west ) THEN 528 CALL iom_gettime ( id_w, ztcobc, cl_vname ) ; CALL iom_close (id_w) ; EXIT 529 ENDIF 530 IF ( lp_obc_north ) THEN 531 CALL iom_gettime ( id_n, ztcobc, cl_vname ) ; CALL iom_close (id_n) ; EXIT 532 ENDIF 533 IF ( lp_obc_south ) THEN 534 CALL iom_gettime ( id_s, ztcobc, cl_vname ) ; CALL iom_close (id_s) ; EXIT 535 ENDIF 536 END DO 537 rdt_obc = ztcobc(2)-ztcobc(1) ! just an information, not used for any computation 538 IF (lwp) WRITE(numout,*) ' obcdta found', itobc,' time steps in the OBC files' 539 IF (lwp) WRITE(numout,*) ' time step of obc data :', rdt_obc,' days' 540 ENDIF 541 zjcnes = zjcnes - rdt/rday ! trick : zcnes is always incremented by rdt/rday in obc_dta! 542 END SUBROUTINE obc_dta_chktime 543 544 # if defined key_dynspg_ts || defined key_dynspg_exp 545 SUBROUTINE obc_dta_bt( kt, kbt ) 546 !!--------------------------------------------------------------------------- 547 !! *** SUBROUTINE obc_dta *** 548 !! 549 !! ** Purpose : time interpolation of barotropic data for time-splitting scheme 550 !! Data at the boundary must be in m2/s 551 !! 552 !! History : 9.0 ! 05-11 (V. garnier) Original code 553 !!--------------------------------------------------------------------------- 554 INTEGER, INTENT( in ) :: kt ! ocean time-step index 555 INTEGER, INTENT( in ) :: kbt ! barotropic ocean time-step index 556 ! 557 INTEGER :: ji, jj ! dummy loop indices 558 INTEGER :: i15 559 INTEGER :: itobcm, itobcp 560 REAL(wp) :: zxy 561 INTEGER :: isrel ! number of seconds since 1/1/1992 562 !!--------------------------------------------------------------------------- 563 564 ! 1. First call: check time frames available in files. 565 ! ------------------------------------------------------- 566 567 IF( kt == nit000 ) THEN 568 569 ! 1.1 Barotropic tangential velocities set to zero 570 ! ------------------------------------------------- 571 IF( lp_obc_east ) vbtfoe(:) = 0.e0 572 IF( lp_obc_west ) vbtfow(:) = 0.e0 573 IF( lp_obc_south ) ubtfos(:) = 0.e0 574 IF( lp_obc_north ) ubtfon(:) = 0.e0 575 576 ! 1.2 Sea surface height and normal barotropic velocities set to zero 577 ! or initial conditions if nobc_dta == 0 578 ! -------------------------------------------------------------------- 579 580 IF( lp_obc_east ) THEN 581 ! initialisation to zero 582 sshedta(:,:) = 0.e0 583 ubtedta(:,:) = 0.e0 584 vbtedta(:,:) = 0.e0 ! tangential component 585 ! ! ================== ! 586 IF( nobc_dta == 0 ) THEN ! initial state used ! 587 ! ! ================== ! 588 ! Fills sedta, tedta, uedta (global arrays) 589 ! Remark: this works for njzoom = 1. Should the definition of ij include njzoom? 590 DO ji = nie0, nie1 591 DO jj = 1, jpj 592 sshedta(jj,1) = sshn(ji+1,jj) * tmask(ji+1,jj,1) 593 END DO 594 END DO 595 ENDIF 596 ENDIF 597 598 IF( lp_obc_west) THEN 599 ! initialisation to zero 600 sshwdta(:,:) = 0.e0 601 ubtwdta(:,:) = 0.e0 602 vbtwdta(:,:) = 0.e0 ! tangential component 603 ! ! ================== ! 604 IF( nobc_dta == 0 ) THEN ! initial state used ! 605 ! ! ================== ! 606 ! Fills swdta, twdta, uwdta (global arrays) 607 ! Remark: this works for njzoom = 1. Should the definition of ij include njzoom? 608 DO ji = niw0, niw1 609 DO jj = 1, jpj 610 sshwdta(jj,1) = sshn(ji,jj) * tmask(ji,jj,1) 611 END DO 612 END DO 613 ENDIF 614 ENDIF 615 616 IF( lp_obc_north) THEN 617 ! initialisation to zero 618 sshndta(:,:) = 0.e0 619 ubtndta(:,:) = 0.e0 ! tangential component 620 vbtndta(:,:) = 0.e0 621 ! ! ================== ! 622 IF( nobc_dta == 0 ) THEN ! initial state used ! 623 ! ! ================== ! 624 ! Fills sndta, tndta, vndta (global arrays) 625 ! Remark: this works for njzoom = 1. Should the definition of ij include njzoom? 626 DO jj = njn0, njn1 627 DO ji = 1, jpi 628 sshndta(ji,1) = sshn(ji,jj+1) * tmask(ji,jj+1,1) 629 END DO 630 END DO 631 ENDIF 632 ENDIF 633 634 IF( lp_obc_south) THEN 635 ! initialisation to zero 636 sshsdta(:,:) = 0.e0 637 ubtsdta(:,:) = 0.e0 ! tangential component 638 vbtsdta(:,:) = 0.e0 639 ! ! ================== ! 640 IF( nobc_dta == 0 ) THEN ! initial state used ! 641 ! ! ================== ! 642 ! Fills ssdta, tsdta, vsdta (global arrays) 643 ! Remark: this works for njzoom = 1. Should the definition of ij include njzoom? 644 DO jj = njs0, njs1 645 DO ji = 1, jpi 646 sshsdta(ji,1) = sshn(ji,jj) * tmask(ji,jj,1) 647 END DO 648 END DO 649 ENDIF 650 ENDIF 651 652 IF( nobc_dta == 0 ) CALL obc_depth_average(1) ! depth averaged velocity from the OBC depth-dependent frames 653 654 ENDIF ! END kt == nit000 655 656 !!------------------------------------------------------------------------------------ 657 ! 2. Initialize the time we are at. Does this every time the routine is called, 658 ! excepted when nobc_dta = 0 659 ! 660 661 ! 3. Call at every time step : Linear interpolation of BCs to current time step 662 ! ---------------------------------------------------------------------- 663 664 IF( lk_dynspg_ts ) THEN 665 isrel = (kt-1)*rdt + kbt*(rdt/REAL(nn_baro,wp)) 666 ELSE IF( lk_dynspg_exp ) THEN 667 isrel=kt*rdt 668 ENDIF 669 670 itobcm = nt_b 671 itobcp = nt_a 672 IF( itobc == 1 .OR. nobc_dta == 0 ) THEN 673 zxy = 0.e0 674 itobcm = 1 675 itobcp = 1 676 ELSE IF( itobc == 12 ) THEN 677 i15 = nday / 16 678 zxy = FLOAT( nday + 15 - 30 * i15 ) / 30. 679 ELSE 680 zxy = (zjcnes_obc(nt_a)-FLOAT(isrel)) / (zjcnes_obc(nt_a)-zjcnes_obc(nt_b)) 681 IF( zxy < 0. ) THEN ! case of extrapolation, switch to old time frames 682 itobcm = nt_m 683 itobcp = nt_b 684 zxy = (zjcnes_obc(nt_b)-FLOAT(isrel)) / (zjcnes_obc(nt_b)-zjcnes_obc(nt_m)) 685 ENDIF 686 ENDIF 687 688 IF( lp_obc_east ) THEN ! fills sshfoe, ubtfoe (local to each processor) 689 DO jj = 1, jpj 690 sshfoe(jj) = zxy * sshedta(jj,itobcp) + (1.-zxy) * sshedta(jj,itobcm) 691 ubtfoe(jj) = zxy * ubtedta(jj,itobcp) + (1.-zxy) * ubtedta(jj,itobcm) 692 vbtfoe(jj) = zxy * vbtedta(jj,itobcp) + (1.-zxy) * vbtedta(jj,itobcm) 693 END DO 694 ENDIF 695 696 IF( lp_obc_west) THEN ! fills sshfow, ubtfow (local to each processor) 697 DO jj = 1, jpj 698 sshfow(jj) = zxy * sshwdta(jj,itobcp) + (1.-zxy) * sshwdta(jj,itobcm) 699 ubtfow(jj) = zxy * ubtwdta(jj,itobcp) + (1.-zxy) * ubtwdta(jj,itobcm) 700 vbtfow(jj) = zxy * vbtwdta(jj,itobcp) + (1.-zxy) * vbtwdta(jj,itobcm) 701 END DO 702 ENDIF 703 704 IF( lp_obc_north) THEN ! fills sshfon, vbtfon (local to each processor) 705 DO ji = 1, jpi 706 sshfon(ji) = zxy * sshndta(ji,itobcp) + (1.-zxy) * sshndta(ji,itobcm) 707 ubtfon(ji) = zxy * ubtndta(ji,itobcp) + (1.-zxy) * ubtndta(ji,itobcm) 708 vbtfon(ji) = zxy * vbtndta(ji,itobcp) + (1.-zxy) * vbtndta(ji,itobcm) 709 END DO 710 ENDIF 711 712 IF( lp_obc_south) THEN ! fills sshfos, vbtfos (local to each processor) 713 DO ji = 1, jpi 714 sshfos(ji) = zxy * sshsdta(ji,itobcp) + (1.-zxy) * sshsdta(ji,itobcm) 715 ubtfos(ji) = zxy * ubtsdta(ji,itobcp) + (1.-zxy) * ubtsdta(ji,itobcm) 716 vbtfos(ji) = zxy * vbtsdta(ji,itobcp) + (1.-zxy) * vbtsdta(ji,itobcm) 717 END DO 718 ENDIF 719 720 END SUBROUTINE obc_dta_bt 721 722 # else 723 !!----------------------------------------------------------------------------- 724 !! Default option 725 !!----------------------------------------------------------------------------- 726 SUBROUTINE obc_dta_bt ( kt, kbt ) ! Empty routine 727 !! * Arguments 728 INTEGER,INTENT(in) :: kt 729 INTEGER, INTENT( in ) :: kbt ! barotropic ocean time-step index 730 WRITE(*,*) 'obc_dta_bt: You should not have seen this print! error?', kt 731 WRITE(*,*) 'obc_dta_bt: You should not have seen this print! error?', kbt 732 END SUBROUTINE obc_dta_bt 733 # endif 734 735 SUBROUTINE obc_read (kt, nt_x, ntobc_x, iyy, imm) 736 !!------------------------------------------------------------------------- 737 !! *** ROUTINE obc_read *** 738 !! 739 !! ** Purpose : Read the boundary data in files identified by iyy and imm 740 !! According to the validated open boundaries, return the 741 !! following arrays : 742 !! sedta, tedta : East OBC salinity and temperature 743 !! uedta, vedta : " " u and v velocity component 744 !! 745 !! swdta, twdta : West OBC salinity and temperature 746 !! uwdta, vwdta : " " u and v velocity component 747 !! 748 !! sndta, tndta : North OBC salinity and temperature 749 !! undta, vndta : " " u and v velocity component 750 !! 751 !! ssdta, tsdta : South OBC salinity and temperature 752 !! usdta, vsdta : " " u and v velocity component 753 !! 754 !! ** Method : These fields are read in the record ntobc_x of the files. 755 !! The number of records is already known. If ntobc_x is greater 756 !! than the number of record, this routine will look for next file, 757 !! updating the indices (case of inter-annual obcs) or loop at the 758 !! begining in case of climatological file (ln_obc_clim = true ). 759 !! ------------------------------------------------------------------------- 760 !! History: ! 2005 ( P. Mathiot, C. Langlais ) Original code 761 !! ! 2008 ( J,M, Molines ) Use IOM and cleaning 762 !!-------------------------------------------------------------------------- 763 764 ! * Arguments 765 INTEGER, INTENT( in ) :: kt, nt_x 766 INTEGER, INTENT( inout ) :: ntobc_x , iyy, imm ! yes ! inout ! 767 768 ! * Local variables 769 CHARACTER (len=40) :: & ! file names 770 cl_obc_eTS , cl_obc_eU, cl_obc_eV,& 771 cl_obc_wTS , cl_obc_wU, cl_obc_wV,& 772 cl_obc_nTS , cl_obc_nU, cl_obc_nV,& 773 cl_obc_sTS , cl_obc_sU, cl_obc_sV 774 775 INTEGER :: ikprint 776 REAL(wp) :: zmin, zmax ! control of boundary values 777 778 !IOM stuff 779 INTEGER :: id_e, id_w, id_n, id_s 780 INTEGER, DIMENSION(2) :: istart, icount 781 782 !-------------------------------------------------------------------------- 783 IF ( ntobc_x > itobc ) THEN 784 IF (ln_obc_clim) THEN ! just loop on the same file 785 ntobc_x = 1 786 ELSE 787 ! need to change file : it is always for an 'after' data 788 IF ( cffile == 'annual' ) THEN ! go to next year file 789 iyy = iyy + 1 790 ELSE IF ( cffile =='monthly' ) THEN ! go to next month file 791 imm = imm + 1 792 IF ( imm == 13 ) THEN 793 imm = 1 ; iyy = iyy + 1 794 ENDIF 795 ELSE 796 ctmp1='obcread : this type of obc file is not supported :( ' 797 ctmp2=TRIM(cffile) 798 CALL ctl_stop (ctmp1, ctmp2) 799 ! cffile should be either annual or monthly ... 800 ENDIF 801 ! as the file is changed, need to update itobc etc ... 802 CALL obc_dta_chktime (iyy,imm) 803 ntobc_x = nrecbef() + 1 ! remember : this case occur for an after data 804 ENDIF 805 ENDIF 806 807 IF( lp_obc_east ) THEN 808 ! ... Read datafile and set temperature, salinity and normal velocity 809 ! ... initialise the sedta, tedta, uedta arrays 810 IF(ln_obc_clim) THEN ! revert to old convention for climatological OBC forcing 811 cl_obc_eTS='obceast_TS.nc' 812 cl_obc_eU ='obceast_U.nc' 813 cl_obc_eV ='obceast_V.nc' 814 ELSE ! convention for climatological OBC 815 WRITE(cl_obc_eTS ,'("obc_east_TS_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 816 WRITE(cl_obc_eU ,'("obc_east_U_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 817 WRITE(cl_obc_eV ,'("obc_east_V_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 818 ENDIF 819 ! JMM this may change depending on the obc data format ... 820 istart(:)=(/nje0+njmpp-1,1/) ; icount(:)=(/nje1-nje0 +1,jpk/) 821 IF (lwp) WRITE(numout,*) 'read data in :', TRIM(cl_obc_eTS) 822 IF (nje1 >= nje0 ) THEN 823 CALL iom_open ( cl_obc_eTS , id_e ) 824 CALL iom_get ( id_e, jpdom_unknown, 'votemper', tedta(nje0:nje1,:,nt_x), & 825 & ktime=ntobc_x , kstart=istart, kcount= icount ) 826 CALL iom_get ( id_e, jpdom_unknown, 'vosaline', sedta(nje0:nje1,:,nt_x), & 827 & ktime=ntobc_x , kstart=istart, kcount= icount ) 828 # if defined key_dynspg_ts || defined key_dynspg_exp 829 CALL iom_get ( id_e, jpdom_unknown, 'vossurfh', sshedta(nje0:nje1,nt_x), & 830 & ktime=ntobc_x , kstart=istart, kcount= icount ) 831 # endif 832 CALL iom_close (id_e) 833 ! 834 CALL iom_open ( cl_obc_eU , id_e ) 835 CALL iom_get ( id_e, jpdom_unknown, 'vozocrtx', uedta(nje0:nje1,:,nt_x), & 836 & ktime=ntobc_x , kstart=istart, kcount= icount ) 837 CALL iom_close ( id_e ) 838 ! 839 CALL iom_open ( cl_obc_eV , id_e ) 840 CALL iom_get ( id_e, jpdom_unknown, 'vomecrty', vedta(nje0:nje1,:,nt_x), & 841 & ktime=ntobc_x , kstart=istart, kcount= icount ) 842 CALL iom_close ( id_e ) 843 844 ! mask the boundary values 845 tedta(:,:,nt_x) = tedta(:,:,nt_x)*temsk(:,:) ; sedta(:,:,nt_x) = sedta(:,:,nt_x)*temsk(:,:) 846 uedta(:,:,nt_x) = uedta(:,:,nt_x)*uemsk(:,:) ; vedta(:,:,nt_x) = vedta(:,:,nt_x)*vemsk(:,:) 847 848 ! check any outliers 849 zmin=MINVAL( sedta(:,:,nt_x), mask=ltemsk ) ; zmax=MAXVAL(sedta(:,:,nt_x), mask=ltemsk) 850 IF ( zmin < 5 .OR. zmax > 50) THEN 851 CALL ctl_stop('Error in sedta',' routine obcdta') 852 ENDIF 853 zmin=MINVAL( tedta(:,:,nt_x), mask=ltemsk ) ; zmax=MAXVAL(tedta(:,:,nt_x), mask=ltemsk) 854 IF ( zmin < -10. .OR. zmax > 40) THEN 855 CALL ctl_stop('Error in tedta',' routine obcdta') 856 ENDIF 857 zmin=MINVAL( uedta(:,:,nt_x), mask=luemsk ) ; zmax=MAXVAL(uedta(:,:,nt_x), mask=luemsk) 858 IF ( zmin < -5. .OR. zmax > 5.) THEN 859 CALL ctl_stop('Error in uedta',' routine obcdta') 860 ENDIF 861 zmin=MINVAL( vedta(:,:,nt_x), mask=lvemsk ) ; zmax=MAXVAL(vedta(:,:,nt_x), mask=lvemsk) 862 IF ( zmin < -5. .OR. zmax > 5.) THEN 863 CALL ctl_stop('Error in vedta',' routine obcdta') 864 ENDIF 865 866 ! Usually printout is done only once at kt = nit000, unless nprint (namelist) > 1 867 IF ( lwp .AND. ( kt == nit000 .OR. nprint /= 0 ) ) THEN 868 WRITE(numout,*) 869 WRITE(numout,*) ' Read East OBC data records ', ntobc_x 870 ikprint = jpj/20 +1 871 WRITE(numout,*) ' Temperature record 1 - printout every 3 level' 872 CALL prihre( tedta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 873 WRITE(numout,*) 874 WRITE(numout,*) ' Salinity record 1 - printout every 3 level' 875 CALL prihre( sedta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 876 WRITE(numout,*) 877 WRITE(numout,*) ' Normal velocity U record 1 - printout every 3 level' 878 CALL prihre( uedta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 879 WRITE(numout,*) 880 WRITE(numout,*) ' Tangential velocity V record 1 - printout every 3 level' 881 CALL prihre( vedta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 882 ENDIF 883 ENDIF 884 ENDIF 885 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 886 IF ( lp_obc_west ) THEN 887 ! ... Read datafile and set temperature, salinity and normal velocity 888 ! ... initialise the swdta, twdta, uwdta arrays 889 IF (ln_obc_clim) THEN ! revert to old convention for climatological OBC forcing 890 cl_obc_wTS='obcwest_TS.nc' 891 cl_obc_wU ='obcwest_U.nc' 892 cl_obc_wV ='obcwest_V.nc' 893 ELSE ! convention for climatological OBC 894 WRITE(cl_obc_wTS ,'("obc_west_TS_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 895 WRITE(cl_obc_wU ,'("obc_west_U_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 896 WRITE(cl_obc_wV ,'("obc_west_V_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 897 ENDIF 898 istart(:)=(/njw0+njmpp-1,1/) ; icount(:)=(/njw1-njw0 +1,jpk/) 899 IF (lwp) WRITE(numout,*) 'read data in :', TRIM(cl_obc_wTS) 900 901 IF ( njw1 >= njw0 ) THEN 902 CALL iom_open ( cl_obc_wTS , id_w ) 903 CALL iom_get ( id_w, jpdom_unknown, 'votemper', twdta(njw0:njw1,:,nt_x), & 904 & ktime=ntobc_x , kstart=istart, kcount= icount ) 905 906 CALL iom_get ( id_w, jpdom_unknown, 'vosaline', swdta(njw0:njw1,:,nt_x), & 907 & ktime=ntobc_x , kstart=istart, kcount= icount) 908 # if defined key_dynspg_ts || defined key_dynspg_exp 909 CALL iom_get ( id_w, jpdom_unknown, 'vossurfh', sshwdta(njw0:njw1,nt_x), & 910 & ktime=ntobc_x , kstart=istart, kcount= icount ) 911 # endif 912 CALL iom_close (id_w) 913 ! 914 CALL iom_open ( cl_obc_wU , id_w ) 915 CALL iom_get ( id_w, jpdom_unknown, 'vozocrtx', uwdta(njw0:njw1,:,nt_x),& 916 & ktime=ntobc_x , kstart=istart, kcount= icount ) 917 CALL iom_close ( id_w ) 918 ! 919 CALL iom_open ( cl_obc_wV , id_w ) 920 CALL iom_get ( id_w, jpdom_unknown, 'vomecrty', vwdta(njw0:njw1,:,nt_x), & 921 & ktime=ntobc_x , kstart=istart, kcount= icount ) 922 CALL iom_close ( id_w ) 923 924 ! mask the boundary values 925 twdta(:,:,nt_x) = twdta(:,:,nt_x)*twmsk(:,:) ; swdta(:,:,nt_x) = swdta(:,:,nt_x)*twmsk(:,:) 926 uwdta(:,:,nt_x) = uwdta(:,:,nt_x)*uwmsk(:,:) ; vwdta(:,:,nt_x) = vwdta(:,:,nt_x)*vwmsk(:,:) 927 928 ! check any outliers 929 zmin=MINVAL( swdta(:,:,nt_x), mask=ltwmsk ) ; zmax=MAXVAL(swdta(:,:,nt_x), mask=ltwmsk) 930 IF ( zmin < 5 .OR. zmax > 50) THEN 931 CALL ctl_stop('Error in swdta',' routine obcdta') 932 ENDIF 933 zmin=MINVAL( twdta(:,:,nt_x), mask=ltwmsk ) ; zmax=MAXVAL(twdta(:,:,nt_x), mask=ltwmsk) 934 IF ( zmin < -10. .OR. zmax > 40) THEN 935 CALL ctl_stop('Error in twdta',' routine obcdta') 936 ENDIF 937 zmin=MINVAL( uwdta(:,:,nt_x), mask=luwmsk ) ; zmax=MAXVAL(uwdta(:,:,nt_x), mask=luwmsk) 938 IF ( zmin < -5. .OR. zmax > 5.) THEN 939 CALL ctl_stop('Error in uwdta',' routine obcdta') 940 ENDIF 941 zmin=MINVAL( vwdta(:,:,nt_x), mask=lvwmsk ) ; zmax=MAXVAL(vwdta(:,:,nt_x), mask=lvwmsk) 942 IF ( zmin < -5. .OR. zmax > 5.) THEN 943 CALL ctl_stop('Error in vwdta',' routine obcdta') 944 ENDIF 945 946 947 IF ( lwp .AND. ( kt == nit000 .OR. nprint /= 0 ) ) THEN 948 WRITE(numout,*) 949 WRITE(numout,*) ' Read West OBC data records ', ntobc_x 950 ikprint = jpj/20 +1 951 WRITE(numout,*) ' Temperature record 1 - printout every 3 level' 952 CALL prihre( twdta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 953 WRITE(numout,*) 954 WRITE(numout,*) ' Salinity record 1 - printout every 3 level' 955 CALL prihre( swdta(:,:,nt_x),jpj,jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 956 WRITE(numout,*) 957 WRITE(numout,*) ' Normal velocity U record 1 - printout every 3 level' 958 CALL prihre( uwdta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 959 WRITE(numout,*) 960 WRITE(numout,*) ' Tangential velocity V record 1 - printout every 3 level' 961 CALL prihre( vwdta(:,:,nt_x), jpj, jpk, 1, jpj, ikprint, jpk, 1, -3, 1., numout ) 962 ENDIF 963 END IF 964 ENDIF 965 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 966 IF( lp_obc_north) THEN 967 IF(ln_obc_clim) THEN ! revert to old convention for climatological OBC forcing 968 cl_obc_nTS='obcnorth_TS.nc' 969 cl_obc_nU ='obcnorth_U.nc' 970 cl_obc_nV ='obcnorth_V.nc' 971 ELSE ! convention for climatological OBC 972 WRITE(cl_obc_nTS ,'("obc_north_TS_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 973 WRITE(cl_obc_nV ,'("obc_north_V_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 974 WRITE(cl_obc_nU ,'("obc_north_U_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 975 ENDIF 976 istart(:)=(/nin0+nimpp-1,1/) ; icount(:)=(/nin1-nin0 +1,jpk/) 977 IF (lwp) WRITE(numout,*) 'read data in :', TRIM(cl_obc_nTS) 978 IF ( nin1 >= nin0 ) THEN 979 CALL iom_open ( cl_obc_nTS , id_n ) 980 CALL iom_get ( id_n, jpdom_unknown, 'votemper', tndta(nin0:nin1,:,nt_x), & 981 & ktime=ntobc_x , kstart=istart, kcount= icount ) 982 CALL iom_get ( id_n, jpdom_unknown, 'vosaline', sndta(nin0:nin1,:,nt_x), & 983 & ktime=ntobc_x , kstart=istart, kcount= icount ) 984 # if defined key_dynspg_ts || defined key_dynspg_exp 985 CALL iom_get ( id_n, jpdom_unknown, 'vossurfh', sshndta(nin0:nin1,nt_x), & 986 & ktime=ntobc_x , kstart=istart, kcount= icount ) 987 # endif 988 CALL iom_close (id_n) 989 ! 990 CALL iom_open ( cl_obc_nU , id_n ) 991 CALL iom_get ( id_n, jpdom_unknown, 'vozocrtx', undta(nin0:nin1,:,nt_x), & 992 & ktime=ntobc_x , kstart=istart, kcount= icount ) 993 CALL iom_close ( id_n ) 994 ! 995 CALL iom_open ( cl_obc_nV , id_n ) 996 CALL iom_get ( id_n, jpdom_unknown, 'vomecrty', vndta(nin0:nin1,:,nt_x), & 997 & ktime=ntobc_x , kstart=istart, kcount= icount ) 998 CALL iom_close ( id_n ) 999 1000 ! mask the boundary values 1001 tndta(:,:,nt_x) = tndta(:,:,nt_x)*tnmsk(:,:) ; sndta(:,:,nt_x) = sndta(:,:,nt_x)*tnmsk(:,:) 1002 undta(:,:,nt_x) = undta(:,:,nt_x)*unmsk(:,:) ; vndta(:,:,nt_x) = vndta(:,:,nt_x)*vnmsk(:,:) 1003 1004 ! check any outliers 1005 zmin=MINVAL( sndta(:,:,nt_x), mask=ltnmsk ) ; zmax=MAXVAL(sndta(:,:,nt_x), mask=ltnmsk) 1006 IF ( zmin < 5 .OR. zmax > 50) THEN 1007 CALL ctl_stop('Error in sndta',' routine obcdta') 1008 ENDIF 1009 zmin=MINVAL( tndta(:,:,nt_x), mask=ltnmsk ) ; zmax=MAXVAL(tndta(:,:,nt_x), mask=ltnmsk) 1010 IF ( zmin < -10. .OR. zmax > 40) THEN 1011 CALL ctl_stop('Error in tndta',' routine obcdta') 1012 ENDIF 1013 zmin=MINVAL( undta(:,:,nt_x), mask=lunmsk ) ; zmax=MAXVAL(undta(:,:,nt_x), mask=lunmsk) 1014 IF ( zmin < -5. .OR. zmax > 5.) THEN 1015 CALL ctl_stop('Error in undta',' routine obcdta') 1016 ENDIF 1017 zmin=MINVAL( vndta(:,:,nt_x), mask=lvnmsk ) ; zmax=MAXVAL(vndta(:,:,nt_x), mask=lvnmsk) 1018 IF ( zmin < -5. .OR. zmax > 5.) THEN 1019 CALL ctl_stop('Error in vndta',' routine obcdta') 1020 ENDIF 1021 1022 IF ( lwp .AND. ( kt == nit000 .OR. nprint /= 0 ) ) THEN 1023 WRITE(numout,*) 1024 WRITE(numout,*) ' Read North OBC data records ', ntobc_x 1025 ikprint = jpi/20 +1 1026 WRITE(numout,*) ' Temperature record 1 - printout every 3 level' 1027 CALL prihre( tndta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1028 WRITE(numout,*) 1029 WRITE(numout,*) ' Salinity record 1 - printout every 3 level' 1030 CALL prihre( sndta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1031 WRITE(numout,*) 1032 WRITE(numout,*) ' Normal velocity V record 1 - printout every 3 level' 1033 CALL prihre( vndta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1034 WRITE(numout,*) 1035 WRITE(numout,*) ' Tangential velocity U record 1 - printout every 3 level' 1036 CALL prihre( undta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1037 ENDIF 1038 ENDIF 1039 ENDIF 1040 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1041 IF( lp_obc_south) THEN 1042 IF(ln_obc_clim) THEN ! revert to old convention for climatological OBC forcing 1043 cl_obc_sTS='obcsouth_TS.nc' 1044 cl_obc_sU ='obcsouth_U.nc' 1045 cl_obc_sV ='obcsouth_V.nc' 1046 ELSE ! convention for climatological OBC 1047 WRITE(cl_obc_sTS ,'("obc_south_TS_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 1048 WRITE(cl_obc_sV ,'("obc_south_V_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 1049 WRITE(cl_obc_sU ,'("obc_south_U_y" ,i4.4,"m",i2.2,".nc")' ) iyy,imm 1050 ENDIF 1051 istart(:)=(/nis0+nimpp-1,1/) ; icount(:)=(/nis1-nis0 +1,jpk/) 1052 IF (lwp) WRITE(numout,*) 'read data in :', TRIM(cl_obc_sTS) 1053 IF ( nis1 >= nis0 ) THEN 1054 CALL iom_open ( cl_obc_sTS , id_s ) 1055 CALL iom_get ( id_s, jpdom_unknown, 'votemper', tsdta(nis0:nis1,:,nt_x), & 1056 & ktime=ntobc_x , kstart=istart, kcount= icount ) 1057 CALL iom_get ( id_s, jpdom_unknown, 'vosaline', ssdta(nis0:nis1,:,nt_x), & 1058 & ktime=ntobc_x , kstart=istart, kcount= icount ) 1059 # if defined key_dynspg_ts || defined key_dynspg_exp 1060 CALL iom_get ( id_s, jpdom_unknown, 'vossurfh', sshsdta(nis0:nis1,nt_x), & 1061 & ktime=ntobc_x , kstart=istart, kcount= icount ) 1062 # endif 1063 CALL iom_close (id_s) 1064 ! 1065 CALL iom_open ( cl_obc_sU , id_s ) 1066 CALL iom_get ( id_s, jpdom_unknown, 'vozocrtx', usdta(nis0:nis1,:,nt_x), & 1067 & ktime=ntobc_x , kstart=istart, kcount= icount ) 1068 CALL iom_close ( id_s ) 1069 ! 1070 CALL iom_open ( cl_obc_sV , id_s ) 1071 CALL iom_get ( id_s, jpdom_unknown, 'vomecrty', vsdta(nis0:nis1,:,nt_x), & 1072 & ktime=ntobc_x , kstart=istart, kcount= icount ) 1073 CALL iom_close ( id_s ) 1074 1075 ! mask the boundary values 1076 tsdta(:,:,nt_x) = tsdta(:,:,nt_x)*tsmsk(:,:) ; ssdta(:,:,nt_x) = ssdta(:,:,nt_x)*tsmsk(:,:) 1077 usdta(:,:,nt_x) = usdta(:,:,nt_x)*usmsk(:,:) ; vsdta(:,:,nt_x) = vsdta(:,:,nt_x)*vsmsk(:,:) 1078 1079 ! check any outliers 1080 zmin=MINVAL( ssdta(:,:,nt_x), mask=ltsmsk ) ; zmax=MAXVAL(ssdta(:,:,nt_x), mask=ltsmsk) 1081 IF ( zmin < 5 .OR. zmax > 50) THEN 1082 CALL ctl_stop('Error in ssdta',' routine obcdta') 1083 ENDIF 1084 zmin=MINVAL( tsdta(:,:,nt_x), mask=ltsmsk ) ; zmax=MAXVAL(tsdta(:,:,nt_x), mask=ltsmsk) 1085 IF ( zmin < -10. .OR. zmax > 40) THEN 1086 CALL ctl_stop('Error in tsdta',' routine obcdta') 1087 ENDIF 1088 zmin=MINVAL( usdta(:,:,nt_x), mask=lusmsk ) ; zmax=MAXVAL(usdta(:,:,nt_x), mask=lusmsk) 1089 IF ( zmin < -5. .OR. zmax > 5.) THEN 1090 CALL ctl_stop('Error in usdta',' routine obcdta') 1091 ENDIF 1092 zmin=MINVAL( vsdta(:,:,nt_x), mask=lvsmsk ) ; zmax=MAXVAL(vsdta(:,:,nt_x), mask=lvsmsk) 1093 IF ( zmin < -5. .OR. zmax > 5.) THEN 1094 CALL ctl_stop('Error in vsdta',' routine obcdta') 1095 ENDIF 1096 1097 IF ( lwp .AND. ( kt == nit000 .OR. nprint /= 0 ) ) THEN 1098 WRITE(numout,*) 1099 WRITE(numout,*) ' Read South OBC data records ', ntobc_x 1100 ikprint = jpi/20 +1 1101 WRITE(numout,*) ' Temperature record 1 - printout every 3 level' 1102 CALL prihre( tsdta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1103 WRITE(numout,*) 1104 WRITE(numout,*) ' Salinity record 1 - printout every 3 level' 1105 CALL prihre( ssdta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1106 WRITE(numout,*) 1107 WRITE(numout,*) ' Normal velocity V record 1 - printout every 3 level' 1108 CALL prihre( vsdta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1109 WRITE(numout,*) 1110 WRITE(numout,*) ' Tangential velocity U record 1 - printout every 3 level' 1111 CALL prihre( usdta(:,:,nt_x), jpi, jpk, 1, jpi, ikprint, jpk, 1, -3, 1., numout ) 1112 ENDIF 1113 ENDIF 1114 ENDIF 1115 1116 # if defined key_dynspg_ts || defined key_dynspg_exp 1117 CALL obc_depth_average(nt_x) ! computation of depth-averaged velocity 1118 # endif 1119 1120 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1121 END SUBROUTINE obc_read 1122 1123 1124 INTEGER FUNCTION nrecbef() 1125 !!----------------------------------------------------------------------- 1126 !! *** FUNCTION nrecbef *** 1127 !! 1128 !! Purpose : - provide the before record number in files, with respect to zjcnes 1129 !! 1130 !! History : 2008-04 : ( J.M. Molines ) Original code 1131 !!----------------------------------------------------------------------- 1132 1133 INTEGER :: it , idum 1134 1135 idum = itobc 1136 DO it =1, itobc 1137 IF ( ztcobc(it) > zjcnes ) THEN ; idum = it - 1 ; EXIT ; ENDIF 1138 ENDDO 1139 ! idum can be 0 (climato, before first record) 1140 IF ( idum == 0 ) THEN 1141 IF ( ln_obc_clim ) THEN 1142 idum = itobc 1143 ELSE 1144 ctmp1='obc_dta: find ntobc == 0 for non climatological file ' 1145 ctmp2='consider adding a first record in your data file ' 1146 CALL ctl_stop(ctmp1, ctmp2) 1147 ENDIF 1148 ENDIF 1149 ! idum can be itobc ( zjcnes > ztcobc (itobc) ) 1150 ! This is not a problem ... 1151 nrecbef = idum 1152 1153 END FUNCTION nrecbef 1154 1155 1156 SUBROUTINE obc_depth_average(nt_x) 1157 !!----------------------------------------------------------------------- 1158 !! *** ROUTINE obc_depth_average *** 1159 !! 1160 !! Purpose : - compute the depth-averaged velocity from depth-dependent OBC frames 1161 !! 1162 !! History : 2009-01 : ( Fred Dupont ) Original code 1163 !!----------------------------------------------------------------------- 1164 1165 ! * Arguments 1166 INTEGER, INTENT( in ) :: nt_x 1167 1168 ! * Local variables 1169 INTEGER :: ji, jj, jk 1170 1171 1172 IF( lp_obc_east ) THEN 1173 ! initialisation to zero 1174 ubtedta(:,nt_x) = 0.e0 1175 vbtedta(:,nt_x) = 0.e0 1176 DO ji = nie0, nie1 1177 DO jj = 1, jpj 1178 DO jk = 1, jpkm1 1179 ubtedta(jj,nt_x) = ubtedta(jj,nt_x) + uedta(jj,jk,nt_x)*fse3u(ji,jj,jk) 1180 vbtedta(jj,nt_x) = vbtedta(jj,nt_x) + vedta(jj,jk,nt_x)*fse3v(ji+1,jj,jk) 1181 END DO 1182 END DO 1183 END DO 1184 ENDIF 1185 1186 IF( lp_obc_west) THEN 1187 ! initialisation to zero 1188 ubtwdta(:,nt_x) = 0.e0 1189 vbtwdta(:,nt_x) = 0.e0 1190 DO ji = niw0, niw1 1191 DO jj = 1, jpj 1192 DO jk = 1, jpkm1 1193 ubtwdta(jj,nt_x) = ubtwdta(jj,nt_x) + uwdta(jj,jk,nt_x)*fse3u(ji,jj,jk) 1194 vbtwdta(jj,nt_x) = vbtwdta(jj,nt_x) + vwdta(jj,jk,nt_x)*fse3v(ji,jj,jk) 1195 END DO 1196 END DO 1197 END DO 1198 ENDIF 1199 1200 IF( lp_obc_north) THEN 1201 ! initialisation to zero 1202 ubtndta(:,nt_x) = 0.e0 1203 vbtndta(:,nt_x) = 0.e0 1204 DO jj = njn0, njn1 1205 DO ji = 1, jpi 1206 DO jk = 1, jpkm1 1207 ubtndta(ji,nt_x) = ubtndta(ji,nt_x) + undta(ji,jk,nt_x)*fse3u(ji,jj+1,jk) 1208 vbtndta(ji,nt_x) = vbtndta(ji,nt_x) + vndta(ji,jk,nt_x)*fse3v(ji,jj,jk) 1209 END DO 1210 END DO 1211 END DO 1212 ENDIF 1213 1214 IF( lp_obc_south) THEN 1215 ! initialisation to zero 1216 ubtsdta(:,nt_x) = 0.e0 1217 vbtsdta(:,nt_x) = 0.e0 1218 DO jj = njs0, njs1 1219 DO ji = nis0, nis1 1220 DO jk = 1, jpkm1 1221 ubtsdta(ji,nt_x) = ubtsdta(ji,nt_x) + usdta(ji,jk,nt_x)*fse3u(ji,jj,jk) 1222 vbtsdta(ji,nt_x) = vbtsdta(ji,nt_x) + vsdta(ji,jk,nt_x)*fse3v(ji,jj,jk) 1223 END DO 1224 END DO 1225 END DO 1226 ENDIF 1227 1228 END SUBROUTINE obc_depth_average 1229 1230 #else 1231 !!------------------------------------------------------------------------------ 1232 !! default option: Dummy module NO Open Boundary Conditions 1233 !!------------------------------------------------------------------------------ 1234 CONTAINS 1235 SUBROUTINE obc_dta( kt ) ! Dummy routine 1236 INTEGER, INTENT (in) :: kt 1237 WRITE(*,*) 'obc_dta: You should not have seen this print! error?', kt 1238 END SUBROUTINE obc_dta 1239 #endif 482 SUBROUTINE obc_dta_init() ! Empty routine 483 WRITE(*,*) 'obc_dta_init: You should not have seen this print! error?' 484 END SUBROUTINE obc_dta_init 485 #endif 486 1240 487 !!============================================================================== 1241 488 END MODULE obcdta -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcini.F90
r2715 r2797 1 1 MODULE obcini 2 2 !!====================================================================== 3 3 !! *** MODULE obcini *** 4 !! OBC initial state : Open boundary initial state4 !! Unstructured open boundaries : initialisation 5 5 !!====================================================================== 6 !! History : 8.0 ! 97-07 (J.M. Molines, G. Madec) Original code 7 !! NEMO 1.0 ! 02-11 (C. Talandier, A-M. Treguier) Free surface, F90 8 !! 2.0 ! 05-11 (V. Garnier) Surface pressure gradient organization 6 !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code 7 !! - ! 2007-01 (D. Storkey) Update to use IOM module 8 !! - ! 2007-01 (D. Storkey) Tidal forcing 9 !! 3.0 ! 2008-04 (NEMO team) add in the reference version 10 !! 3.3 ! 2010-09 (E.O'Dea) updates for Shelf configurations 11 !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions 12 !! 3.4 ! 2011 (D. Storkey, J. Chanut) OBC-BDY merge 13 !! ! --- Renamed bdyini.F90 -> obcini.F90 --- 9 14 !!---------------------------------------------------------------------- 10 15 #if defined key_obc 11 16 !!---------------------------------------------------------------------- 12 !! 'key_obc' 17 !! 'key_obc' Unstructured Open Boundary Conditions 13 18 !!---------------------------------------------------------------------- 14 !! obc_init : initialization for the open boundary condition19 !! obc_init : Initialization of unstructured open boundaries 15 20 !!---------------------------------------------------------------------- 16 21 USE oce ! ocean dynamics and tracers variables 17 USE dom_oce ! ocean space and time domain variables 22 USE dom_oce ! ocean space and time domain 23 USE obc_oce ! unstructured open boundary conditions 24 USE obctides ! tides at open boundaries initialization (tide_init routine) 25 USE in_out_manager ! I/O units 18 26 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 19 USE phycst ! physical constants 20 USE obc_oce ! open boundary condition: ocean 21 USE obcdta ! open boundary condition: data 22 USE in_out_manager ! I/O units 23 USE lib_mpp ! MPP library 24 USE dynspg_oce ! flag lk_dynspg_flt 27 USE lib_mpp ! for mpp_sum 28 USE iom ! I/O 25 29 26 30 IMPLICIT NONE … … 29 33 PUBLIC obc_init ! routine called by opa.F90 30 34 31 !! * Substitutions32 # include "obc_vectopt_loop_substitute.h90"33 35 !!---------------------------------------------------------------------- 34 !! NEMO/OPA 3.3 , NEMO Consortium (2010)36 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 35 37 !! $Id$ 36 38 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 42 44 !! *** ROUTINE obc_init *** 43 45 !! 44 !! ** Purpose : Initialization of the dynamics and tracer fields at45 !! theopen boundaries.46 !! ** Purpose : Initialization of the dynamics and tracer fields with 47 !! unstructured open boundaries. 46 48 !! 47 !! ** Method : initialization of open boundary variables 48 !! (u, v) over 3 time step and 3 rows 49 !! (t, s) over 2 time step and 2 rows 50 !! if ln_rstart = .FALSE. : no restart, fields set to zero 51 !! if ln_rstart = .TRUE. : restart, fields are read in a file 52 !! if rdpxxx = 0 then lfbc is set true for this boundary. 49 !! ** Method : Read initialization arrays (mask, indices) to identify 50 !! an unstructured open boundary 53 51 !! 54 !! ** Input : restart.obc file, restart file for open boundaries 52 !! ** Input : obc_init.nc, input file for unstructured open boundaries 53 !!---------------------------------------------------------------------- 54 INTEGER :: ib_obc, ii, ij, ik, igrd, ib, ir ! dummy loop indices 55 INTEGER :: icount, icountr, ibr_max, ilen1 ! local integers 56 INTEGER :: iw, ie, is, in, inum, id_dummy ! - - 57 INTEGER :: igrd_start, igrd_end, jpbdta ! - - 58 INTEGER, POINTER :: nbi, nbj, nbr ! short cuts 59 REAL , POINTER :: flagu, flagv ! - - 60 REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars 61 INTEGER, DIMENSION (2) :: kdimsz 62 INTEGER, DIMENSION(jpbgrd,jp_obc) :: nblendta ! Length of index arrays 63 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbidta, nbjdta ! Index arrays: i and j indices of obc dta 64 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbrdta ! Discrete distance from rim points 65 REAL(wp), DIMENSION(jpidta,jpjdta) :: zmask ! global domain mask 66 CHARACTER(LEN=80),DIMENSION(jpbgrd) :: clfile 67 CHARACTER(LEN=1),DIMENSION(jpbgrd) :: cgrid 68 !! 69 NAMELIST/namobc/ nb_obc, ln_coords_file, cn_coords_file, & 70 & ln_mask_file, cn_mask_file, nn_dyn2d, nn_dyn3d, & 71 & nn_tra, & 72 #if defined key_lim2 73 & nn_ice_lim2, & 74 #endif 75 & ln_tides, ln_vol, ln_clim, nn_dtactl, nn_volctl, & 76 & nn_rimwidth, nn_dmp2d_in, nn_dmp2d_out, & 77 & nn_dmp3d_in, nn_dmp3d_out 55 78 !!---------------------------------------------------------------------- 56 USE obcrst, ONLY : obc_rst_read ! Make obc_rst_read routine available 57 !! 58 INTEGER :: ji, jj, istop , inumfbc 59 INTEGER, DIMENSION(4) :: icorner 60 REAL(wp), DIMENSION(2) :: ztestmask 61 !! 62 NAMELIST/namobc/ rn_dpein, rn_dpwin, rn_dpnin, rn_dpsin, & 63 & rn_dpeob, rn_dpwob, rn_dpnob, rn_dpsob, & 64 & rn_volemp, nn_obcdta, cn_obcdta, & 65 & ln_obc_clim, ln_vol_cst, ln_obc_fla 66 !!---------------------------------------------------------------------- 67 68 REWIND( numnam ) ! Namelist namobc : open boundaries 69 READ ( numnam, namobc ) 70 71 ! convert DOCTOR namelist name into the OLD names 72 nobc_dta = nn_obcdta 73 cffile = cn_obcdta 74 rdpein = rn_dpein 75 rdpwin = rn_dpwin 76 rdpsin = rn_dpsin 77 rdpnin = rn_dpnin 78 rdpeob = rn_dpeob 79 rdpwob = rn_dpwob 80 rdpsob = rn_dpsob 81 rdpnob = rn_dpnob 82 volemp = rn_volemp 83 84 ! ! allocate obc arrays 85 IF( obc_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'obc_init : unable to allocate obc_oce arrays' ) 86 IF( obc_dta_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'obc_init : unable to allocate obc_dta arrays' ) 87 88 ! By security we set rdpxin and rdpxob respectively to 1. and 15. if the corresponding OBC is not activated 89 IF( .NOT.lp_obc_east ) THEN ; rdpein = 1. ; rdpeob = 15. ; END IF 90 IF( .NOT.lp_obc_west ) THEN ; rdpwin = 1. ; rdpwob = 15. ; END IF 91 IF( .NOT.lp_obc_north ) THEN ; rdpnin = 1. ; rdpnob = 15. ; END IF 92 IF( .NOT.lp_obc_south ) THEN ; rdpsin = 1. ; rdpsob = 15. ; END IF 93 94 ! number of open boudaries and open boundary indicators 95 nbobc = 0 96 IF( lp_obc_east ) nbobc = nbobc + 1 97 IF( lp_obc_west ) nbobc = nbobc + 1 98 IF( lp_obc_north ) nbobc = nbobc + 1 99 IF( lp_obc_south ) nbobc = nbobc + 1 79 80 IF( obc_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'obc_init : unable to allocate oce arrays' ) 100 81 101 82 IF(lwp) WRITE(numout,*) 102 83 IF(lwp) WRITE(numout,*) 'obc_init : initialization of open boundaries' 103 84 IF(lwp) WRITE(numout,*) '~~~~~~~~' 104 IF(lwp) WRITE(numout,*) ' Number of open boundaries nbobc = ', nbobc 105 IF(lwp) WRITE(numout,*) 106 107 ! control prints 108 IF(lwp) WRITE(numout,*) ' Namelist namobc' 109 IF(lwp) WRITE(numout,*) ' data in file (=1) or initial state used (=0) nn_obcdta = ', nn_obcdta 110 IF(lwp) WRITE(numout,*) ' climatology (true) or not ln_obc_clim = ', ln_obc_clim 111 IF(lwp) WRITE(numout,*) ' vol_cst (true) or not: ln_vol_cst = ', ln_vol_cst 112 IF(lwp) WRITE(numout,*) ' ' 113 IF(lwp) WRITE(numout,*) ' WARNING ' 114 IF(lwp) WRITE(numout,*) ' Flather"s algorithm is applied with explicit free surface scheme ' 115 IF(lwp) WRITE(numout,*) ' or with free surface time-splitting scheme ' 116 IF(lwp) WRITE(numout,*) ' Nor radiation neither relaxation is allowed with explicit free surface scheme: ' 117 IF(lwp) WRITE(numout,*) ' Radiation and/or relaxation is allowed with free surface time-splitting scheme ' 118 IF(lwp) WRITE(numout,*) ' depending of the choice of rdpXin = rdpXob = 0. for open boundaries ' 119 IF(lwp) WRITE(numout,*) 120 IF(lwp) WRITE(numout,*) ' For the filtered free surface case, ' 121 IF(lwp) WRITE(numout,*) ' radiation, relaxation or presciption of data can be applied ' 122 IF(lwp) WRITE(numout,*) 123 124 IF( lwp.AND.lp_obc_east ) THEN 125 WRITE(numout,*) ' East open boundary :' 126 WRITE(numout,*) ' i index jpieob = ', jpieob 127 WRITE(numout,*) ' damping time scale (days) rn_dpeob = ', rn_dpeob 128 WRITE(numout,*) ' damping time scale (days) rn_dpein = ', rn_dpein 85 ! 86 87 IF( jperio /= 0 ) CALL ctl_stop( 'Cyclic or symmetric,', & 88 & ' and general open boundary condition are not compatible' ) 89 90 cgrid= (/'T','U','V'/) 91 92 ! ----------------------------------------- 93 ! Initialise and read namelist parameters 94 ! ----------------------------------------- 95 96 nb_obc = 0 97 ln_coords_file(:) = .false. 98 cn_coords_file(:) = '' 99 ln_mask_file = .false. 100 cn_mask_file(:) = '' 101 nn_dyn2d(:) = 0 102 nn_dyn3d(:) = 0 103 nn_tra(:) = 0 104 #if defined key_lim2 105 nn_ice_lim2(:) = 0 106 #endif 107 ln_tides(:) = .false. 108 ln_vol = .false. 109 ln_clim(:) = .false. 110 nn_dtactl(:) = -1 ! uninitialised flag 111 nn_volctl = -1 ! uninitialised flag 112 nn_rimwidth(:) = -1 ! uninitialised flag 113 nn_dmp2d_in(:) = -1 ! uninitialised flag 114 nn_dmp2d_out(:) = -1 ! uninitialised flag 115 nn_dmp3d_in(:) = -1 ! uninitialised flag 116 nn_dmp3d_out(:) = -1 ! uninitialised flag 117 118 REWIND( numnam ) 119 READ ( numnam, namobc ) 120 121 ! ----------------------------------------- 122 ! Check and write out namelist parameters 123 ! ----------------------------------------- 124 125 ! ! control prints 126 IF(lwp) WRITE(numout,*) ' namobc' 127 128 IF( nb_obc .eq. 0 ) THEN 129 IF(lwp) WRITE(numout,*) 'nb_obc = 0, NO OPEN BOUNDARIES APPLIED.' 130 ELSE 131 IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ',nb_obc 129 132 ENDIF 130 133 131 IF( lwp.AND.lp_obc_west ) THEN 132 WRITE(numout,*) ' West open boundary :' 133 WRITE(numout,*) ' i index jpiwob = ', jpiwob 134 WRITE(numout,*) ' damping time scale (days) rn_dpwob = ', rn_dpwob 135 WRITE(numout,*) ' damping time scale (days) rn_dpwin = ', rn_dpwin 134 DO ib_obc = 1,nb_obc 135 IF(lwp) WRITE(numout,*) ' ' 136 IF(lwp) WRITE(numout,*) '------ Open boundary data set ',ib_obc,'------' 137 138 ! ! check type of data used (nn_dtactl value) 139 SELECT CASE( nn_dtactl(ib_obc) ) ! 140 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for obc data' 141 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' 142 CASE DEFAULT ; CALL ctl_stop( 'nn_dtactl must be 0 or 1' ) 143 END SELECT 144 IF(lwp) WRITE(numout,*) 145 146 IF(lwp) WRITE(numout,*) 'Boundary conditions for barotropic solution: ' 147 SELECT CASE( nn_dyn2d(ib_obc) ) 148 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' no open boundary condition' 149 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 150 CASE( 2 ) ; IF(lwp) WRITE(numout,*) ' Flather radiation condition' 151 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_dyn2d' ) 152 END SELECT 153 IF(lwp) WRITE(numout,*) 154 155 IF(lwp) WRITE(numout,*) 'Boundary conditions for baroclinic velocities: ' 156 SELECT CASE( nn_dyn3d(ib_obc) ) 157 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' no open boundary condition' 158 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 159 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_dyn3d' ) 160 END SELECT 161 IF(lwp) WRITE(numout,*) 162 163 IF(lwp) WRITE(numout,*) 'Boundary conditions for temperature and salinity: ' 164 SELECT CASE( nn_tra(ib_obc) ) 165 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' no open boundary condition' 166 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 167 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_tra' ) 168 END SELECT 169 IF(lwp) WRITE(numout,*) 170 171 #if defined key_lim2 172 IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice: ' 173 SELECT CASE( nn_tra(ib_obc) ) 174 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' no open boundary condition' 175 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 176 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_tra' ) 177 END SELECT 178 IF(lwp) WRITE(numout,*) 179 #endif 180 181 IF(lwp) WRITE(numout,*) 'Boundary rim width for the FRS nn_rimwidth = ', nn_rimwidth 182 IF(lwp) WRITE(numout,*) 183 184 IF( ln_tides(ib_obc) ) THEN 185 IF(lwp) WRITE(numout,*) 'Tidal harmonic forcing at unstructured open boundaries' 186 IF(lwp) WRITE(numout,*) 187 ENDIF 188 189 !!$ ! Presumably will need to read in a separate namelist for each boundary that includes tides??? 190 !!$ IF( ln_tides ) CALL tide_init( ib_obc ) ! Read tides namelist 191 192 193 ENDDO 194 195 IF( ln_vol ) THEN ! check volume conservation (nn_volctl value) 196 IF(lwp) WRITE(numout,*) 'Volume correction applied at open boundaries' 197 IF(lwp) WRITE(numout,*) 198 SELECT CASE ( nn_volctl ) 199 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' The total volume will be constant' 200 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' The total volume will vary according to the surface E-P flux' 201 CASE DEFAULT ; CALL ctl_stop( 'nn_volctl must be 0 or 1' ) 202 END SELECT 203 IF(lwp) WRITE(numout,*) 204 ELSE 205 IF(lwp) WRITE(numout,*) 'No volume correction applied at open boundaries' 206 IF(lwp) WRITE(numout,*) 207 ENDIF 208 209 ! ------------------------------------------------- 210 ! Initialise indices arrays for open boundaries 211 ! ------------------------------------------------- 212 213 ! Work out global dimensions of boundary data 214 ! --------------------------------------------- 215 DO ib_obc = 1, nb_obc 216 217 jpbdta = 1 218 IF( .NOT. ln_coords_file(ib_obc) ) THEN ! Work out size of global arrays from namelist parameters 219 220 221 !! 1. Read parameters from namelist 222 !! 2. Work out global size of boundary data arrays nblendta and jpbdta 223 224 225 ELSE ! Read size of arrays in boundary coordinates file. 226 227 228 CALL iom_open( cn_coords_file(ib_obc), inum ) 229 jpbdta = 1 230 DO igrd = 1, jpbgrd 231 id_dummy = iom_varid( inum, 'nbi'//cgrid(igrd), kdimsz=kdimsz ) 232 nblendta(igrd,ib_obc) = kdimsz(1) 233 jpbdta = MAX(jpbdta, kdimsz(1)) 234 ENDDO 235 236 ENDIF 237 238 ENDDO 239 240 ! Allocate arrays 241 !--------------- 242 ALLOCATE( nbidta(jpbdta, jpbgrd, nb_obc), nbjdta(jpbdta, jpbgrd, nb_obc), & 243 & nbrdta(jpbdta, jpbgrd, nb_obc) ) 244 245 ALLOCATE( dta_global(jpbdta, 1, jpk) ) 246 247 ! Calculate global boundary index arrays or read in from file 248 !------------------------------------------------------------ 249 DO ib_obc = 1, nb_obc 250 251 IF( .NOT. ln_coords_file(ib_obc) ) THEN ! Calculate global index arrays from namelist parameters 252 253 !! Calculate global index arrays from namelist parameters 254 255 ELSE ! Read global index arrays from boundary coordinates file. 256 257 DO igrd = 1, jpbgrd 258 CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_obc),:,1) ) 259 DO ii = 1,nblendta(igrd,ib_obc) 260 nbidta(ii,igrd,ib_obc) = INT( dta_global(ii,1,1) ) 261 END DO 262 CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_obc),:,1) ) 263 DO ii = 1,nblendta(igrd,ib_obc) 264 nbjdta(ii,igrd,ib_obc) = INT( dta_global(ii,1,1) ) 265 END DO 266 CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_obc),:,1) ) 267 DO ii = 1,nblendta(igrd,ib_obc) 268 nbrdta(ii,igrd,ib_obc) = INT( dta_global(ii,1,1) ) 269 END DO 270 271 ibr_max = MAXVAL( nbrdta(:,igrd,ib_obc) ) 272 IF(lwp) WRITE(numout,*) 273 IF(lwp) WRITE(numout,*) ' Maximum rimwidth in file is ', ibr_max 274 IF(lwp) WRITE(numout,*) ' nn_rimwidth from namelist is ', nn_rimwidth(ib_obc) 275 IF (ibr_max < nn_rimwidth(ib_obc)) & 276 CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_obc) ) 277 278 END DO 279 CALL iom_close( inum ) 280 281 ENDIF 282 283 ENDDO 284 285 ! Work out dimensions of boundary data on each processor 286 ! ------------------------------------------------------ 287 288 iw = mig(1) + 1 ! if monotasking and no zoom, iw=2 289 ie = mig(1) + nlci-1 - 1 ! if monotasking and no zoom, ie=jpim1 290 is = mjg(1) + 1 ! if monotasking and no zoom, is=2 291 in = mjg(1) + nlcj-1 - 1 ! if monotasking and no zoom, in=jpjm1 292 293 DO ib_obc = 1, nb_obc 294 DO igrd = 1, jpbgrd 295 icount = 0 296 icountr = 0 297 idx_obc(ib_obc)%nblen(igrd) = 0 298 idx_obc(ib_obc)%nblenrim(igrd) = 0 299 DO ib = 1, nblendta(igrd,ib_obc) 300 ! check if point is in local domain 301 IF( nbidta(ib,igrd,ib_obc) >= iw .AND. nbidta(ib,igrd,ib_obc) <= ie .AND. & 302 & nbjdta(ib,igrd,ib_obc) >= is .AND. nbjdta(ib,igrd,ib_obc) <= in ) THEN 303 ! 304 icount = icount + 1 305 ! 306 IF( nbrdta(ib,igrd,ib_obc) == 1 ) icountr = icountr+1 307 ENDIF 308 ENDDO 309 idx_obc(ib_obc)%nblenrim(igrd) = icountr !: length of rim boundary data on each proc 310 idx_obc(ib_obc)%nblen (igrd) = icount !: length of boundary data on each proc 311 ENDDO ! igrd 312 313 ! Allocate index arrays for this boundary set 314 !-------------------------------------------- 315 ilen1 = MAXVAL(idx_obc(ib_obc)%nblen(:)) 316 ALLOCATE( idx_obc(ib_obc)%nbi(ilen1,jpbgrd) ) 317 ALLOCATE( idx_obc(ib_obc)%nbj(ilen1,jpbgrd) ) 318 ALLOCATE( idx_obc(ib_obc)%nbr(ilen1,jpbgrd) ) 319 ALLOCATE( idx_obc(ib_obc)%nbmap(ilen1,jpbgrd) ) 320 ALLOCATE( idx_obc(ib_obc)%nbw(ilen1,jpbgrd) ) 321 ALLOCATE( idx_obc(ib_obc)%flagu(ilen1) ) 322 ALLOCATE( idx_obc(ib_obc)%flagv(ilen1) ) 323 324 ! Dispatch mapping indices and discrete distances on each processor 325 ! ----------------------------------------------------------------- 326 327 DO igrd = 1, jpbgrd 328 icount = 0 329 ! Loop on rimwidth to ensure outermost points come first in the local arrays. 330 DO ir=1, nn_rimwidth(ib_obc) 331 DO ib = 1, nblendta(igrd,ib_obc) 332 ! check if point is in local domain and equals ir 333 IF( nbidta(ib,igrd,ib_obc) >= iw .AND. nbidta(ib,igrd,ib_obc) <= ie .AND. & 334 & nbjdta(ib,igrd,ib_obc) >= is .AND. nbjdta(ib,igrd,ib_obc) <= in .AND. & 335 & nbrdta(ib,igrd,ib_obc) == ir ) THEN 336 ! 337 icount = icount + 1 338 idx_obc(ib_obc)%nbi(icount,igrd) = nbidta(ib,igrd,ib_obc)- mig(1)+1 339 idx_obc(ib_obc)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_obc)- mjg(1)+1 340 idx_obc(ib_obc)%nbr(icount,igrd) = nbrdta(ib,igrd,ib_obc) 341 idx_obc(ib_obc)%nbmap(icount,igrd) = ib 342 ENDIF 343 ENDDO 344 ENDDO 345 ENDDO 346 347 ! Compute rim weights 348 ! ------------------- 349 DO igrd = 1, jpbgrd 350 DO ib = 1, idx_obc(ib_obc)%nblen(igrd) 351 nbr => idx_obc(ib_obc)%nbr(ib,igrd) 352 idx_obc(ib_obc)%nbw(ib,igrd) = 1.- TANH( FLOAT( nbr - 1 ) *0.5 ) ! tanh formulation 353 ! idx_obc(ib_obc)%nbw(ib,igrd) = (FLOAT(nn_rimwidth+1-nbr)/FLOAT(nn_rimwidth))**2 ! quadratic 354 ! idx_obc(ib_obc)%nbw(ib,igrd) = FLOAT(nn_rimwidth+1-nbr)/FLOAT(nn_rimwidth) ! linear 355 END DO 356 END DO 357 358 ENDDO 359 360 ! ------------------------------------------------------ 361 ! Initialise masks and find normal/tangential directions 362 ! ------------------------------------------------------ 363 364 ! Read global 2D mask at T-points: obctmask 365 ! ----------------------------------------- 366 ! obctmask = 1 on the computational domain AND on open boundaries 367 ! = 0 elsewhere 368 369 IF( cp_cfg == "eel" .AND. jp_cfg == 5 ) THEN ! EEL configuration at 5km resolution 370 zmask( : ,:) = 0.e0 371 zmask(jpizoom+1:jpizoom+jpiglo-2,:) = 1.e0 372 ELSE IF( ln_mask_file ) THEN 373 CALL iom_open( cn_mask_file, inum ) 374 CALL iom_get ( inum, jpdom_data, 'obc_msk', zmask(:,:) ) 375 CALL iom_close( inum ) 376 ELSE 377 zmask(:,:) = 1.e0 136 378 ENDIF 137 379 138 IF( lwp.AND.lp_obc_north ) THEN 139 WRITE(numout,*) ' North open boundary :' 140 WRITE(numout,*) ' j index jpjnob = ', jpjnob 141 WRITE(numout,*) ' damping time scale (days) rn_dpnob = ', rn_dpnob 142 WRITE(numout,*) ' damping time scale (days) rn_dpnin = ', rn_dpnin 143 ENDIF 144 145 IF( lwp.AND.lp_obc_south ) THEN 146 WRITE(numout,*) ' South open boundary :' 147 WRITE(numout,*) ' j index jpjsob = ', jpjsob 148 WRITE(numout,*) ' damping time scale (days) rn_dpsob = ', rn_dpsob 149 WRITE(numout,*) ' damping time scale (days) rn_dpsin = ', rn_dpsin 150 WRITE(numout,*) 151 ENDIF 152 153 IF( nbobc >= 2 .AND. jperio /= 0 ) & 154 & CALL ctl_stop( ' Cyclic or symmetric, and open boundary condition are not compatible' ) 155 156 ! 1. Initialisation of constants 157 ! ------------------------------ 158 ! ... convert rdp$ob in seconds 159 ! Fixed Bdy flag inbound outbound 160 lfbceast = .FALSE. ; rdpein = rdpein * rday ; rdpeob = rdpeob * rday 161 lfbcwest = .FALSE. ; rdpwin = rdpwin * rday ; rdpwob = rdpwob * rday 162 lfbcnorth = .FALSE. ; rdpnin = rdpnin * rday ; rdpnob = rdpnob * rday 163 lfbcsouth = .FALSE. ; rdpsin = rdpsin * rday ; rdpsob = rdpsob * rday 164 inumfbc = 0 165 ! ... look for Fixed Boundaries (rdp = 0 ) 166 ! ... When specified, lbcxxx flags are set to TRUE and rdpxxx are set to 167 ! ... a small arbitrary value, (to avoid division by zero further on). 168 ! ... rdpxxx is not used anymore. 169 IF( lp_obc_east ) THEN 170 IF( (rdpein+rdpeob) == 0 ) THEN 171 lfbceast = .TRUE. ; rdpein = 1e-3 ; rdpeob = 1e-3 172 inumfbc = inumfbc+1 173 ELSEIF ( (rdpein*rdpeob) == 0 ) THEN 174 CALL ctl_stop( 'obc_init : rn_dpein & rn_dpeob must be both zero or non zero' ) 175 END IF 176 END IF 177 178 IF( lp_obc_west ) THEN 179 IF( (rdpwin + rdpwob) == 0 ) THEN 180 lfbcwest = .TRUE. ; rdpwin = 1e-3 ; rdpwob = 1e-3 181 inumfbc = inumfbc+1 182 ELSEIF ( (rdpwin*rdpwob) == 0 ) THEN 183 CALL ctl_stop( 'obc_init : rn_dpwin & rn_dpwob must be both zero or non zero' ) 184 END IF 185 END IF 186 IF( lp_obc_north ) THEN 187 IF( (rdpnin + rdpnob) == 0 ) THEN 188 lfbcnorth = .TRUE. ; rdpnin = 1e-3 ; rdpnob = 1e-3 189 inumfbc = inumfbc+1 190 ELSEIF ( (rdpnin*rdpnob) == 0 ) THEN 191 CALL ctl_stop( 'obc_init : rn_dpnin & rn_dpnob must be both zero or non zero' ) 192 END IF 193 END IF 194 IF( lp_obc_south ) THEN 195 IF( (rdpsin + rdpsob) == 0 ) THEN 196 lfbcsouth = .TRUE. ; rdpsin = 1e-3 ; rdpsob = 1e-3 197 inumfbc = inumfbc+1 198 ELSEIF ( (rdpsin*rdpsob) == 0 ) THEN 199 CALL ctl_stop( 'obc_init : rn_dpsin & rn_dpsob must be both zero or non zero' ) 200 END IF 201 END IF 202 203 ! 2. Clever mpp indices for loops on the open boundaries. 204 ! The loops will be performed only on the processors 205 ! that contain a given open boundary. 206 ! -------------------------------------------------------- 207 208 IF( lp_obc_east ) THEN 209 ! ... mpp initialization 210 nie0 = max( 1, min(jpieob - nimpp+1, jpi ) ) 211 nie1 = max( 0, min(jpieob - nimpp+1, jpi - 1 ) ) 212 nie0p1 = max( 1, min(jpieob+1 - nimpp+1, jpi ) ) 213 nie1p1 = max( 0, min(jpieob+1 - nimpp+1, jpi - 1 ) ) 214 nie0m1 = max( 1, min(jpieob-1 - nimpp+1, jpi ) ) 215 nie1m1 = max( 0, min(jpieob-1 - nimpp+1, jpi - 1 ) ) 216 nje0 = max( 2, min(jpjed - njmpp+1, jpj ) ) 217 nje1 = max( 0, min(jpjef - njmpp+1, jpj - 1 ) ) 218 nje0p1 = max( 1, min(jpjedp1 - njmpp+1, jpj ) ) 219 nje0m1 = max( 1, min(jpjed - njmpp+1, jpj ) ) 220 nje1m1 = max( 0, min(jpjefm1 - njmpp+1, jpj - 1 ) ) 221 nje1m2 = max( 0, min(jpjefm1-1- njmpp+1, jpj - 1 ) ) 222 IF(lwp) THEN 223 IF( lfbceast ) THEN 224 WRITE(numout,*)' ' 225 WRITE(numout,*)' Specified East Open Boundary' 380 DO ij = 1, nlcj ! Save mask over local domain 381 DO ii = 1, nlci 382 obctmask(ii,ij) = zmask( mig(ii), mjg(ij) ) 383 END DO 384 END DO 385 386 ! Derive mask on U and V grid from mask on T grid 387 obcumask(:,:) = 0.e0 388 obcvmask(:,:) = 0.e0 389 DO ij=1, jpjm1 390 DO ii=1, jpim1 391 obcumask(ii,ij)=obctmask(ii,ij)*obctmask(ii+1, ij ) 392 obcvmask(ii,ij)=obctmask(ii,ij)*obctmask(ii ,ij+1) 393 END DO 394 END DO 395 CALL lbc_lnk( obcumask(:,:), 'U', 1. ) ; CALL lbc_lnk( obcvmask(:,:), 'V', 1. ) ! Lateral boundary cond. 396 397 398 ! Mask corrections 399 ! ---------------- 400 DO ik = 1, jpkm1 401 DO ij = 1, jpj 402 DO ii = 1, jpi 403 tmask(ii,ij,ik) = tmask(ii,ij,ik) * obctmask(ii,ij) 404 umask(ii,ij,ik) = umask(ii,ij,ik) * obcumask(ii,ij) 405 vmask(ii,ij,ik) = vmask(ii,ij,ik) * obcvmask(ii,ij) 406 bmask(ii,ij) = bmask(ii,ij) * obctmask(ii,ij) 407 END DO 408 END DO 409 END DO 410 411 DO ik = 1, jpkm1 412 DO ij = 2, jpjm1 413 DO ii = 2, jpim1 414 fmask(ii,ij,ik) = fmask(ii,ij,ik) * obctmask(ii,ij ) * obctmask(ii+1,ij ) & 415 & * obctmask(ii,ij+1) * obctmask(ii+1,ij+1) 416 END DO 417 END DO 418 END DO 419 420 tmask_i (:,:) = tmask(:,:,1) * tmask_i(:,:) 421 obctmask(:,:) = tmask(:,:,1) 422 423 ! obc masks and bmask are now set to zero on boundary points: 424 igrd = 1 ! In the free surface case, bmask is at T-points 425 DO ib_obc = 1, nb_obc 426 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd) 427 bmask(idx_obc(ib_obc)%nbi(ib,igrd), idx_obc(ib_obc)%nbj(ib,igrd)) = 0.e0 428 ENDDO 429 ENDDO 430 ! 431 igrd = 1 432 DO ib_obc = 1, nb_obc 433 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd) 434 obctmask(idx_obc(ib_obc)%nbi(ib,igrd), idx_obc(ib_obc)%nbj(ib,igrd)) = 0.e0 435 ENDDO 436 ENDDO 437 ! 438 igrd = 2 439 DO ib_obc = 1, nb_obc 440 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd) 441 obcumask(idx_obc(ib_obc)%nbi(ib,igrd), idx_obc(ib_obc)%nbj(ib,igrd)) = 0.e0 442 ENDDO 443 ENDDO 444 ! 445 igrd = 3 446 DO ib_obc = 1, nb_obc 447 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd) 448 obcvmask(idx_obc(ib_obc)%nbi(ib,igrd), idx_obc(ib_obc)%nbj(ib,igrd)) = 0.e0 449 ENDDO 450 ENDDO 451 452 ! Lateral boundary conditions 453 CALL lbc_lnk( fmask , 'F', 1. ) ; CALL lbc_lnk( obctmask(:,:), 'T', 1. ) 454 CALL lbc_lnk( obcumask(:,:), 'U', 1. ) ; CALL lbc_lnk( obcvmask(:,:), 'V', 1. ) 455 456 DO ib_obc = 1, nb_obc ! Indices and directions of rim velocity components 457 458 idx_obc(ib_obc)%flagu(:) = 0.e0 459 idx_obc(ib_obc)%flagv(:) = 0.e0 460 icount = 0 461 462 !flagu = -1 : u component is normal to the dynamical boundary but its direction is outward 463 !flagu = 0 : u is tangential 464 !flagu = 1 : u is normal to the boundary and is direction is inward 465 466 igrd = 2 ! u-component 467 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd) 468 nbi => idx_obc(ib_obc)%nbi(ib,igrd) 469 nbj => idx_obc(ib_obc)%nbj(ib,igrd) 470 zefl = obctmask(nbi ,nbj) 471 zwfl = obctmask(nbi+1,nbj) 472 IF( zefl + zwfl == 2 ) THEN 473 icount = icount + 1 226 474 ELSE 227 WRITE(numout,*)' ' 228 WRITE(numout,*)' Radiative East Open Boundary' 475 idx_obc(ib_obc)%flagu(ib)=-zefl+zwfl 476 ENDIF 477 END DO 478 479 !flagv = -1 : u component is normal to the dynamical boundary but its direction is outward 480 !flagv = 0 : u is tangential 481 !flagv = 1 : u is normal to the boundary and is direction is inward 482 483 igrd = 3 ! v-component 484 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd) 485 nbi => idx_obc(ib_obc)%nbi(ib,igrd) 486 nbj => idx_obc(ib_obc)%nbj(ib,igrd) 487 znfl = obctmask(nbi,nbj ) 488 zsfl = obctmask(nbi,nbj+1) 489 IF( znfl + zsfl == 2 ) THEN 490 icount = icount + 1 491 ELSE 492 idx_obc(ib_obc)%flagv(ib) = -znfl + zsfl 229 493 END IF 230 END IF 231 END IF 232 233 IF( lp_obc_west ) THEN 234 ! ... mpp initialization 235 niw0 = max( 1, min(jpiwob - nimpp+1, jpi ) ) 236 niw1 = max( 0, min(jpiwob - nimpp+1, jpi - 1 ) ) 237 niw0p1 = max( 1, min(jpiwob+1 - nimpp+1, jpi ) ) 238 niw1p1 = max( 0, min(jpiwob+1 - nimpp+1, jpi - 1 ) ) 239 njw0 = max( 2, min(jpjwd - njmpp+1, jpj ) ) 240 njw1 = max( 0, min(jpjwf - njmpp+1, jpj - 1 ) ) 241 njw0p1 = max( 1, min(jpjwdp1 - njmpp+1, jpj ) ) 242 njw0m1 = max( 1, min(jpjwd - njmpp+1, jpj ) ) 243 njw1m1 = max( 0, min(jpjwfm1 - njmpp+1, jpj - 1 ) ) 244 njw1m2 = max( 0, min(jpjwfm1-1- njmpp+1, jpj - 1 ) ) 245 IF(lwp) THEN 246 IF( lfbcwest ) THEN 247 WRITE(numout,*)' ' 248 WRITE(numout,*)' Specified West Open Boundary' 249 ELSE 250 WRITE(numout,*)' ' 251 WRITE(numout,*)' Radiative West Open Boundary' 252 END IF 253 END IF 254 END IF 494 END DO 255 495 256 IF( lp_obc_north ) THEN 257 ! ... mpp initialization 258 nin0 = max( 2, min(jpind - nimpp+1, jpi ) ) 259 nin1 = max( 0, min(jpinf - nimpp+1, jpi - 1 ) ) 260 nin0p1 = max( 1, min(jpindp1 - nimpp+1, jpi ) ) 261 nin0m1 = max( 1, min(jpind - nimpp+1, jpi ) ) 262 nin1m1 = max( 0, min(jpinfm1 - nimpp+1, jpi - 1 ) ) 263 nin1m2 = max( 0, min(jpinfm1-1- nimpp+1, jpi - 1 ) ) 264 njn0 = max( 1, min(jpjnob - njmpp+1, jpj ) ) 265 njn1 = max( 0, min(jpjnob - njmpp+1, jpj - 1 ) ) 266 njn0p1 = max( 1, min(jpjnob+1 - njmpp+1, jpj ) ) 267 njn1p1 = max( 0, min(jpjnob+1 - njmpp+1, jpj - 1 ) ) 268 njn0m1 = max( 1, min(jpjnob-1 - njmpp+1, jpj ) ) 269 njn1m1 = max( 0, min(jpjnob-1 - njmpp+1, jpj - 1 ) ) 270 IF(lwp) THEN 271 IF( lfbcnorth ) THEN 272 WRITE(numout,*)' ' 273 WRITE(numout,*)' Specified North Open Boundary' 274 ELSE 275 WRITE(numout,*)' ' 276 WRITE(numout,*)' Radiative North Open Boundary' 277 END IF 278 END IF 279 END IF 280 281 IF( lp_obc_south ) THEN 282 ! ... mpp initialization 283 nis0 = max( 2, min(jpisd - nimpp+1, jpi ) ) 284 nis1 = max( 0, min(jpisf - nimpp+1, jpi - 1 ) ) 285 nis0p1 = max( 1, min(jpisdp1 - nimpp+1, jpi ) ) 286 nis0m1 = max( 1, min(jpisd - nimpp+1, jpi ) ) 287 nis1m1 = max( 0, min(jpisfm1 - nimpp+1, jpi - 1 ) ) 288 nis1m2 = max( 0, min(jpisfm1-1- nimpp+1, jpi - 1 ) ) 289 njs0 = max( 1, min(jpjsob - njmpp+1, jpj ) ) 290 njs1 = max( 0, min(jpjsob - njmpp+1, jpj - 1 ) ) 291 njs0p1 = max( 1, min(jpjsob+1 - njmpp+1, jpj ) ) 292 njs1p1 = max( 0, min(jpjsob+1 - njmpp+1, jpj - 1 ) ) 293 IF(lwp) THEN 294 IF( lfbcsouth ) THEN 295 WRITE(numout,*)' ' 296 WRITE(numout,*)' Specified South Open Boundary' 297 ELSE 298 WRITE(numout,*)' ' 299 WRITE(numout,*)' Radiative South Open Boundary' 300 END IF 301 END IF 302 END IF 303 304 ! 3. mask correction for OBCs 305 ! --------------------------- 306 307 IF( lp_obc_east ) THEN 308 !... (jpjed,jpjefm1),jpieob 309 bmask(nie0p1:nie1p1,nje0:nje1m1) = 0.e0 310 311 ! ... initilization to zero 312 uemsk(:,:) = 0.e0 ; vemsk(:,:) = 0.e0 ; temsk(:,:) = 0.e0 313 314 ! ... set 2D mask on East OBC, Vopt 315 DO ji = fs_nie0, fs_nie1 316 DO jj = nje0, nje1 317 uemsk(jj,:) = umask(ji, jj,:) * tmask_i(ji,jj) * tmask_i(ji+1,jj) 318 vemsk(jj,:) = vmask(ji+1,jj,:) * tmask_i(ji+1,jj) 319 temsk(jj,:) = tmask(ji+1,jj,:) * tmask_i(ji+1,jj) 320 END DO 321 END DO 322 323 END IF 324 325 IF( lp_obc_west ) THEN 326 ! ... (jpjwd,jpjwfm1),jpiwob 327 bmask(niw0:niw1,njw0:njw1m1) = 0.e0 328 329 ! ... initilization to zero 330 uwmsk(:,:) = 0.e0 ; vwmsk(:,:) = 0.e0 ; twmsk(:,:) = 0.e0 331 332 ! ... set 2D mask on West OBC, Vopt 333 DO ji = fs_niw0, fs_niw1 334 DO jj = njw0, njw1 335 uwmsk(jj,:) = umask(ji,jj,:) * tmask_i(ji,jj) * tmask_i(ji+1,jj) 336 vwmsk(jj,:) = vmask(ji,jj,:) * tmask_i(ji,jj) 337 twmsk(jj,:) = tmask(ji,jj,:) * tmask_i(ji,jj) 338 END DO 339 END DO 340 341 END IF 342 343 IF( lp_obc_north ) THEN 344 ! ... jpjnob,(jpind,jpisfm1) 345 bmask(nin0:nin1m1,njn0p1:njn1p1) = 0.e0 346 347 ! ... initilization to zero 348 unmsk(:,:) = 0.e0 ; vnmsk(:,:) = 0.e0 ; tnmsk(:,:) = 0.e0 349 350 ! ... set 2D mask on North OBC, Vopt 351 DO jj = fs_njn0, fs_njn1 352 DO ji = nin0, nin1 353 unmsk(ji,:) = umask(ji,jj+1,:) * tmask_i(ji,jj+1) 354 vnmsk(ji,:) = vmask(ji,jj ,:) * tmask_i(ji,jj) * tmask_i(ji,jj+1) 355 tnmsk(ji,:) = tmask(ji,jj+1,:) * tmask_i(ji,jj+1) 356 END DO 357 END DO 358 359 END IF 360 361 IF( lp_obc_south ) THEN 362 ! ... jpjsob,(jpisd,jpisfm1) 363 bmask(nis0:nis1m1,njs0:njs1) = 0.e0 364 365 ! ... initilization to zero 366 usmsk(:,:) = 0.e0 ; vsmsk(:,:) = 0.e0 ; tsmsk(:,:) = 0.e0 367 368 ! ... set 2D mask on South OBC, Vopt 369 DO jj = fs_njs0, fs_njs1 370 DO ji = nis0, nis1 371 usmsk(ji,:) = umask(ji,jj,:) * tmask_i(ji,jj) 372 vsmsk(ji,:) = vmask(ji,jj,:) * tmask_i(ji,jj) * tmask_i(ji,jj+1) 373 tsmsk(ji,:) = tmask(ji,jj,:) * tmask_i(ji,jj) 374 END DO 375 END DO 376 377 END IF 378 379 ! ... Initialize obcumask and obcvmask for the Force filtering 380 ! boundary condition in dynspg_flt 381 obcumask(:,:) = umask(:,:,1) 382 obcvmask(:,:) = vmask(:,:,1) 383 384 ! ... Initialize obctmsk on overlap region and obcs. This mask 385 ! is used in obcvol.F90 to calculate cumulate flux E-P. 386 ! obc Tracer point are outside the domain ( U/V obc points) ==> masked by obctmsk 387 ! - no flux E-P on obcs and overlap region (jpreci = jprecj = 1) 388 obctmsk(:,:) = tmask_i(:,:) 389 390 IF( lp_obc_east ) THEN 391 ! ... East obc Force filtering mask for the grad D 392 obcumask(nie0 :nie1 ,nje0p1:nje1m1) = 0.e0 393 obcvmask(nie0p1:nie1p1,nje0p1:nje1m1) = 0.e0 394 ! ... set to 0 on East OBC 395 obctmsk(nie0p1:nie1p1,nje0:nje1) = 0.e0 396 END IF 397 398 IF( lp_obc_west ) THEN 399 ! ... West obc Force filtering mask for the grad D 400 obcumask(niw0:niw1,njw0:njw1) = 0.e0 401 obcvmask(niw0:niw1,njw0:njw1) = 0.e0 402 ! ... set to 0 on West OBC 403 obctmsk(niw0:niw1,njw0:njw1) = 0.e0 404 END IF 405 406 IF( lp_obc_north ) THEN 407 ! ... North obc Force filtering mask for the grad D 408 obcumask(nin0p1:nin1m1,njn0p1:njn1p1) = 0.e0 409 obcvmask(nin0p1:nin1m1,njn0 :njn1 ) = 0.e0 410 ! ... set to 0 on North OBC 411 obctmsk(nin0:nin1,njn0p1:njn1p1) = 0.e0 412 END IF 413 414 IF( lp_obc_south ) THEN 415 ! ... South obc Force filtering mask for the grad D 416 obcumask(nis0p1:nis1m1,njs0:njs1) = 0.e0 417 obcvmask(nis0p1:nis1m1,njs0:njs1) = 0.e0 418 ! ... set to 0 on South OBC 419 obctmsk(nis0:nis1,njs0:njs1) = 0.e0 420 END IF 421 422 ! 3.1 Total lateral surface 423 ! ------------------------- 424 obcsurftot = 0.e0 425 426 IF( lp_obc_east ) THEN ! ... East open boundary lateral surface 427 DO ji = nie0, nie1 428 DO jj = 1, jpj 429 obcsurftot = obcsurftot+hu(ji,jj)*e2u(ji,jj)*uemsk(jj,1) * MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 430 END DO 431 END DO 432 END IF 433 434 IF( lp_obc_west ) THEN ! ... West open boundary lateral surface 435 DO ji = niw0, niw1 436 DO jj = 1, jpj 437 obcsurftot = obcsurftot+hu(ji,jj)*e2u(ji,jj)*uwmsk(jj,1) * MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 438 END DO 439 END DO 440 END IF 441 442 IF( lp_obc_north ) THEN ! ... North open boundary lateral surface 443 DO jj = njn0, njn1 444 DO ji = 1, jpi 445 obcsurftot = obcsurftot+hv(ji,jj)*e1v(ji,jj)*vnmsk(ji,1) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 446 END DO 447 END DO 448 END IF 449 450 IF( lp_obc_south ) THEN ! ... South open boundary lateral surface 451 DO jj = njs0, njs1 452 DO ji = 1, jpi 453 obcsurftot = obcsurftot+hv(ji,jj)*e1v(ji,jj)*vsmsk(ji,1) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 454 END DO 455 END DO 456 END IF 457 458 IF( lk_mpp ) CALL mpp_sum( obcsurftot ) ! sum over the global domain 459 460 ! 5. Control print on mask 461 ! The extremities of the open boundaries must be in land 462 ! or else correspond to an "ocean corner" between two open boundaries. 463 ! corner 1 is southwest, 2 is south east, 3 is northeast, 4 is northwest. 464 ! -------------------------------------------------------------------------- 465 466 icorner(:)=0 467 468 ! ... control of the west boundary 469 IF( lp_obc_west ) THEN 470 IF( jpiwob < 2 .OR. jpiwob >= jpiglo-2 ) THEN 471 WRITE(ctmp1,*) ' jpiwob exceed ', jpiglo-2, 'or less than 2' 472 CALL ctl_stop( ctmp1 ) 473 END IF 474 ztestmask(:)=0. 475 DO ji=niw0,niw1 476 IF( (njw0 + njmpp - 1) == jpjwd ) ztestmask(1)=ztestmask(1)+ tmask(ji,njw0,1) 477 IF( (njw1 + njmpp - 1) == jpjwf ) ztestmask(2)=ztestmask(2)+ tmask(ji,njw1,1) 478 END DO 479 IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain 480 481 IF( ztestmask(1) /= 0. ) icorner(1)=icorner(1)+1 482 IF( ztestmask(2) /= 0. ) icorner(4)=icorner(4)+1 483 END IF 484 485 ! ... control of the east boundary 486 IF( lp_obc_east ) THEN 487 IF( jpieob < 4 .OR. jpieob >= jpiglo ) THEN 488 WRITE(ctmp1,*) ' jpieob exceed ', jpiglo, ' or less than 4' 489 CALL ctl_stop( ctmp1 ) 490 END IF 491 ztestmask(:)=0. 492 DO ji=nie0p1,nie1p1 493 IF( (nje0 + njmpp - 1) == jpjed ) ztestmask(1)=ztestmask(1)+ tmask(ji,nje0,1) 494 IF( (nje1 + njmpp - 1) == jpjef ) ztestmask(2)=ztestmask(2)+ tmask(ji,nje1,1) 495 END DO 496 IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain 497 498 IF( ztestmask(1) /= 0. ) icorner(2)=icorner(2)+1 499 IF( ztestmask(2) /= 0. ) icorner(3)=icorner(3)+1 500 END IF 501 502 ! ... control of the north boundary 503 IF( lp_obc_north ) THEN 504 IF( jpjnob < 4 .OR. jpjnob >= jpjglo ) THEN 505 WRITE(ctmp1,*) 'jpjnob exceed ', jpjglo, ' or less than 4' 506 CALL ctl_stop( ctmp1 ) 507 END IF 508 ztestmask(:)=0. 509 DO jj=njn0p1,njn1p1 510 IF( (nin0 + nimpp - 1) == jpind ) ztestmask(1)=ztestmask(1)+ tmask(nin0,jj,1) 511 IF( (nin1 + nimpp - 1) == jpinf ) ztestmask(2)=ztestmask(2)+ tmask(nin1,jj,1) 512 END DO 513 IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain 514 515 IF( ztestmask(1) /= 0. ) icorner(4)=icorner(4)+1 516 IF( ztestmask(2) /= 0. ) icorner(3)=icorner(3)+1 517 END IF 518 519 ! ... control of the south boundary 520 IF( lp_obc_south ) THEN 521 IF( jpjsob < 2 .OR. jpjsob >= jpjglo-2 ) THEN 522 WRITE(ctmp1,*) ' jpjsob exceed ', jpjglo-2, ' or less than 2' 523 CALL ctl_stop( ctmp1 ) 524 END IF 525 ztestmask(:)=0. 526 DO jj=njs0,njs1 527 IF( (nis0 + nimpp - 1) == jpisd ) ztestmask(1)=ztestmask(1)+ tmask(nis0,jj,1) 528 IF( (nis1 + nimpp - 1) == jpisf ) ztestmask(2)=ztestmask(2)+ tmask(nis1,jj,1) 529 END DO 530 IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain 531 532 IF( ztestmask(1) /= 0. ) icorner(1)=icorner(1)+1 533 IF( ztestmask(2) /= 0. ) icorner(2)=icorner(2)+1 534 END IF 535 536 IF( icorner(1) == 2 ) THEN 537 IF(lwp) WRITE(numout,*) 538 IF(lwp) WRITE(numout,*) ' South West ocean corner, two open boudaries' 539 IF(lwp) WRITE(numout,*) ' ========== ' 540 IF(lwp) WRITE(numout,*) 541 IF( jpisd /= jpiwob.OR.jpjsob /= jpjwd ) & 542 & CALL ctl_stop( ' Open boundaries do not fit, we stop' ) 543 544 ELSE IF( icorner(1) == 1 ) THEN 545 CALL ctl_stop( ' Open boundaries do not fit at SW corner, we stop' ) 546 END IF 547 548 IF( icorner(2) == 2 ) THEN 549 IF(lwp) WRITE(numout,*) 550 IF(lwp) WRITE(numout,*) ' South East ocean corner, two open boudaries' 551 IF(lwp) WRITE(numout,*) ' ========== ' 552 IF(lwp) WRITE(numout,*) 553 IF( jpisf /= jpieob+1.OR.jpjsob /= jpjed ) & 554 & CALL ctl_stop( ' Open boundaries do not fit, we stop' ) 555 ELSE IF( icorner(2) == 1 ) THEN 556 CALL ctl_stop( ' Open boundaries do not fit at SE corner, we stop' ) 557 END IF 558 559 IF( icorner(3) == 2 ) THEN 560 IF(lwp) WRITE(numout,*) 561 IF(lwp) WRITE(numout,*) ' North East ocean corner, two open boudaries' 562 IF(lwp) WRITE(numout,*) ' ========== ' 563 IF(lwp) WRITE(numout,*) 564 IF( jpinf /= jpieob+1 .OR. jpjnob+1 /= jpjef ) & 565 & CALL ctl_stop( ' Open boundaries do not fit, we stop' ) 566 ELSE IF( icorner(3) == 1 ) THEN 567 CALL ctl_stop( ' Open boundaries do not fit at NE corner, we stop' ) 568 END IF 569 570 IF( icorner(4) == 2 ) THEN 571 IF(lwp) WRITE(numout,*) 572 IF(lwp) WRITE(numout,*) ' North West ocean corner, two open boudaries' 573 IF(lwp) WRITE(numout,*) ' ========== ' 574 IF(lwp) WRITE(numout,*) 575 IF( jpind /= jpiwob.OR.jpjnob+1 /= jpjwf ) & 576 & CALL ctl_stop( ' Open boundaries do not fit, we stop' ) 577 ELSE IF( icorner(4) == 1 ) THEN 578 CALL ctl_stop( ' Open boundaries do not fit at NW corner, we stop' ) 579 END IF 580 581 ! 6. Initialization of open boundary variables (u, v, t, s) 582 ! -------------------------------------------------------------- 583 ! only if at least one boundary is radiative 584 IF ( inumfbc < nbobc .AND. ln_rstart ) THEN 585 ! Restart from restart.obc 586 CALL obc_rst_read 587 ELSE 588 589 ! ! ... Initialization to zero of radiation arrays. 590 ! ! Those have dimensions of local subdomains 591 592 uebnd(:,:,:,:) = 0.e0 ; unbnd(:,:,:,:) = 0.e0 593 vebnd(:,:,:,:) = 0.e0 ; vnbnd(:,:,:,:) = 0.e0 594 tebnd(:,:,:,:) = 0.e0 ; tnbnd(:,:,:,:) = 0.e0 595 sebnd(:,:,:,:) = 0.e0 ; snbnd(:,:,:,:) = 0.e0 596 597 uwbnd(:,:,:,:) = 0.e0 ; usbnd(:,:,:,:) = 0.e0 598 vwbnd(:,:,:,:) = 0.e0 ; vsbnd(:,:,:,:) = 0.e0 599 twbnd(:,:,:,:) = 0.e0 ; tsbnd(:,:,:,:) = 0.e0 600 swbnd(:,:,:,:) = 0.e0 ; ssbnd(:,:,:,:) = 0.e0 601 602 END IF 603 604 ! 7. Control print 605 ! ----------------------------------------------------------------- 606 607 ! ... control of the east boundary 608 IF( lp_obc_east ) THEN 609 istop = 0 610 IF( jpieob < 4 .OR. jpieob >= jpiglo ) THEN 611 IF(lwp) WRITE(numout,cform_err) 612 IF(lwp) WRITE(numout,*) ' jpieob exceed ', jpim1, ' or less than 4' 613 istop = istop + 1 614 END IF 615 616 IF( lk_mpp ) THEN 617 ! ... 618 IF( nimpp > jpieob-5) THEN 619 IF(lwp) WRITE(numout,cform_err) 620 IF(lwp) WRITE(numout,*) ' A sub-domain is too close to the East OBC' 621 IF(lwp) WRITE(numout,*) ' nimpp must be < jpieob-5' 622 istop = istop + 1 623 ENDIF 624 ELSE 625 626 ! ... stop if e r r o r (s) detected 627 IF( istop /= 0 ) THEN 628 WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop' 629 CALL ctl_stop( ctmp1 ) 630 ENDIF 631 ENDIF 632 ENDIF 633 634 ! ... control of the west boundary 635 IF( lp_obc_west ) THEN 636 istop = 0 637 IF( jpiwob < 2 .OR. jpiwob >= jpiglo ) THEN 638 IF(lwp) WRITE(numout,cform_err) 639 IF(lwp) WRITE(numout,*) ' jpiwob exceed ', jpim1, ' or less than 2' 640 istop = istop + 1 641 END IF 642 643 IF( lk_mpp ) THEN 644 IF( (nimpp < jpiwob+5) .AND. (nimpp > 1) ) THEN 645 IF(lwp) WRITE(numout,cform_err) 646 IF(lwp) WRITE(numout,*) ' A sub-domain is too close to the West OBC' 647 IF(lwp) WRITE(numout,*) ' nimpp must be > jpiwob-5 or =1' 648 istop = istop + 1 649 ENDIF 650 ELSE 651 652 ! ... stop if e r r o r (s) detected 653 IF( istop /= 0 ) THEN 654 WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop' 655 CALL ctl_stop( ctmp1 ) 656 ENDIF 657 ENDIF 658 ENDIF 659 660 ! control of the north boundary 661 IF( lp_obc_north ) THEN 662 istop = 0 663 IF( jpjnob < 4 .OR. jpjnob >= jpjglo ) THEN 664 IF(lwp) WRITE(numout,cform_err) 665 IF(lwp) WRITE(numout,*) ' jpjnob exceed ', jpjm1,' or less than 4' 666 istop = istop + 1 667 END IF 668 669 IF( lk_mpp ) THEN 670 IF( njmpp > jpjnob-5) THEN 671 IF(lwp) WRITE(numout,cform_err) 672 IF(lwp) WRITE(numout,*) ' A sub-domain is too close to the North OBC' 673 IF(lwp) WRITE(numout,*) ' njmpp must be < jpjnob-5' 674 istop = istop + 1 675 ENDIF 676 ELSE 677 678 ! ... stop if e r r o r (s) detected 679 IF( istop /= 0 ) THEN 680 WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop' 681 CALL ctl_stop( ctmp1 ) 682 ENDIF 683 ENDIF 684 ENDIF 685 686 ! control of the south boundary 687 IF( lp_obc_south ) THEN 688 istop = 0 689 IF( jpjsob < 2 .OR. jpjsob >= jpjglo ) THEN 690 IF(lwp) WRITE(numout,cform_err) 691 IF(lwp) WRITE(numout,*) ' jpjsob exceed ', jpjm1,' or less than 2' 692 istop = istop + 1 693 END IF 694 695 IF( lk_mpp ) THEN 696 IF( (njmpp < jpjsob+5) .AND. (njmpp > 1) ) THEN 697 IF(lwp) WRITE(numout,cform_err) 698 IF(lwp) WRITE(numout,*) ' A sub-domain is too close to the South OBC' 699 IF(lwp) WRITE(numout,*) ' njmpp must be > jpjsob+5 or =1' 700 istop = istop + 1 701 ENDIF 702 ELSE 703 704 ! ... stop if e r r o r (s) detected 705 IF( istop /= 0 ) THEN 706 WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop' 707 CALL ctl_stop( ctmp1 ) 708 ENDIF 709 ENDIF 710 ENDIF 496 IF( icount /= 0 ) THEN 497 IF(lwp) WRITE(numout,*) 498 IF(lwp) WRITE(numout,*) ' E R R O R : Some data velocity points,', & 499 ' are not boundary points. Check nbi, nbj, indices for boundary set ',ib_obc 500 IF(lwp) WRITE(numout,*) ' ========== ' 501 IF(lwp) WRITE(numout,*) 502 nstop = nstop + 1 503 ENDIF 504 505 ENDDO 506 507 ! Compute total lateral surface for volume correction: 508 ! ---------------------------------------------------- 509 obcsurftot = 0.e0 510 IF( ln_vol ) THEN 511 igrd = 2 ! Lateral surface at U-points 512 DO ib_obc = 1, nb_obc 513 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd) 514 nbi => idx_obc(ib_obc)%nbi(ib,igrd) 515 nbj => idx_obc(ib_obc)%nbi(ib,igrd) 516 flagu => idx_obc(ib_obc)%flagu(ib) 517 obcsurftot = obcsurftot + hu (nbi , nbj) & 518 & * e2u (nbi , nbj) * ABS( flagu ) & 519 & * tmask_i(nbi , nbj) & 520 & * tmask_i(nbi+1, nbj) 521 ENDDO 522 ENDDO 523 524 igrd=3 ! Add lateral surface at V-points 525 DO ib_obc = 1, nb_obc 526 DO ib = 1, idx_obc(ib_obc)%nblenrim(igrd) 527 nbi => idx_obc(ib_obc)%nbi(ib,igrd) 528 nbj => idx_obc(ib_obc)%nbi(ib,igrd) 529 flagv => idx_obc(ib_obc)%flagv(ib) 530 obcsurftot = obcsurftot + hv (nbi, nbj ) & 531 & * e1v (nbi, nbj ) * ABS( flagv ) & 532 & * tmask_i(nbi, nbj ) & 533 & * tmask_i(nbi, nbj+1) 534 ENDDO 535 ENDDO 536 ! 537 IF( lk_mpp ) CALL mpp_sum( obcsurftot ) ! sum over the global domain 538 END IF 539 540 ! Read in tidal constituents and adjust for model start time 541 ! ---------------------------------------------------------- 542 !!$ IF( ln_tides ) CALL tide_data 543 ! 544 ! Tidy up 545 !-------- 546 DEALLOCATE(nbidta, nbjdta, nbrdta) 711 547 712 548 END SUBROUTINE obc_init … … 714 550 #else 715 551 !!--------------------------------------------------------------------------------- 716 !! Dummy module NOopen boundaries552 !! Dummy module NO unstructured open boundaries 717 553 !!--------------------------------------------------------------------------------- 718 554 CONTAINS -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcrad.F90
r2715 r2797 5 5 !!================================================================================= 6 6 #if defined key_obc 7 !!---------------------------------------------------------------------------------8 !! obc_rad : call the subroutine for each open boundary9 !! obc_rad_east : compute the east phase velocities10 !! obc_rad_west : compute the west phase velocities11 !! obc_rad_north : compute the north phase velocities12 !! obc_rad_south : compute the south phase velocities13 !!---------------------------------------------------------------------------------14 USE oce ! ocean dynamics and tracers variables15 USE dom_oce ! ocean space and time domain variables16 USE lbclnk ! ocean lateral boundary conditions (or mpp link)17 USE phycst ! physical constants18 USE obc_oce ! ocean open boundary conditions19 USE lib_mpp ! for mppobc20 USE in_out_manager ! I/O units21 22 IMPLICIT NONE23 PRIVATE24 25 PUBLIC obc_rad ! routine called by step.F9026 27 INTEGER :: ji, jj, jk ! dummy loop indices28 29 INTEGER :: & ! ... boundary space indices30 nib = 1, & ! nib = boundary point31 nibm = 2, & ! nibm = 1st interior point32 nibm2 = 3, & ! nibm2 = 2nd interior point33 ! ... boundary time indices34 nit = 1, & ! nit = now35 nitm = 2, & ! nitm = before36 nitm2 = 3 ! nitm2 = before-before37 38 !! * Substitutions39 # include "obc_vectopt_loop_substitute.h90"40 !!---------------------------------------------------------------------------------41 !! NEMO/OPA 3.3 , NEMO Consortium (2010)42 !! $Id$43 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)44 !!---------------------------------------------------------------------------------45 46 CONTAINS47 48 SUBROUTINE obc_rad ( kt )49 !!------------------------------------------------------------------------------50 !! SUBROUTINE obc_rad51 !! ********************52 !! ** Purpose :53 !! Perform swap of arrays to calculate radiative phase speeds at the open54 !! boundaries and calculate those phase speeds if the open boundaries are55 !! not fixed. In case of fixed open boundaries does nothing.56 !!57 !! The logical variable lp_obc_east, and/or lp_obc_west, and/or lp_obc_north,58 !! and/or lp_obc_south allow the user to determine which boundary is an59 !! open one (must be done in the param_obc.h90 file).60 !!61 !! ** Reference :62 !! Marchesiello P., 1995, these de l'universite J. Fourier, Grenoble, France.63 !!64 !! History :65 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 from the66 !! J. Molines and G. Madec version67 !!------------------------------------------------------------------------------68 INTEGER, INTENT( in ) :: kt69 !!----------------------------------------------------------------------70 71 IF( lp_obc_east .AND. .NOT.lfbceast ) CALL obc_rad_east ( kt ) ! East open boundary72 73 IF( lp_obc_west .AND. .NOT.lfbcwest ) CALL obc_rad_west ( kt ) ! West open boundary74 75 IF( lp_obc_north .AND. .NOT.lfbcnorth ) CALL obc_rad_north( kt ) ! North open boundary76 77 IF( lp_obc_south .AND. .NOT.lfbcsouth ) CALL obc_rad_south( kt ) ! South open boundary78 79 END SUBROUTINE obc_rad80 81 82 SUBROUTINE obc_rad_east ( kt )83 !!------------------------------------------------------------------------------84 !! *** SUBROUTINE obc_rad_east ***85 !!86 !! ** Purpose :87 !! Perform swap of arrays to calculate radiative phase speeds at the open88 !! east boundary and calculate those phase speeds if this OBC is not fixed.89 !! In case of fixed OBC, this subrountine is not called.90 !!91 !! History :92 !! ! 95-03 (J.-M. Molines) Original from SPEM93 !! ! 97-07 (G. Madec, J.-M. Molines) additions94 !! ! 97-12 (M. Imbard) Mpp adaptation95 !! ! 00-06 (J.-M. Molines)96 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F9097 !!------------------------------------------------------------------------------98 !! * Arguments99 INTEGER, INTENT( in ) :: kt100 101 !! * Local declarations102 INTEGER :: ij103 REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy104 REAL(wp) :: zucb, zucbm, zucbm2105 !!------------------------------------------------------------------------------106 107 ! 1. Swap arrays before calculating radiative velocities108 ! ------------------------------------------------------109 110 ! 1.1 zonal velocity111 ! -------------------112 113 IF( kt > nit000 .OR. ln_rstart ) THEN114 115 ! ... advance in time (time filter, array swap)116 DO jk = 1, jpkm1117 DO jj = 1, jpj118 uebnd(jj,jk,nib ,nitm2) = uebnd(jj,jk,nib ,nitm)*uemsk(jj,jk)119 uebnd(jj,jk,nibm ,nitm2) = uebnd(jj,jk,nibm ,nitm)*uemsk(jj,jk)120 uebnd(jj,jk,nibm2,nitm2) = uebnd(jj,jk,nibm2,nitm)*uemsk(jj,jk)121 END DO122 END DO123 ! ... fields nitm <== nit plus time filter at the boundary124 DO ji = fs_nie0, fs_nie1 ! Vector opt.125 DO jk = 1, jpkm1126 DO jj = 1, jpj127 uebnd(jj,jk,nib ,nitm) = uebnd(jj,jk,nib, nit)*uemsk(jj,jk)128 uebnd(jj,jk,nibm ,nitm) = uebnd(jj,jk,nibm ,nit)*uemsk(jj,jk)129 uebnd(jj,jk,nibm2,nitm) = uebnd(jj,jk,nibm2,nit)*uemsk(jj,jk)130 ! ... fields nit <== now (kt+1)131 ! ... Total or baroclinic velocity at b, bm and bm2132 zucb = un(ji,jj,jk)133 zucbm = un(ji-1,jj,jk)134 zucbm2 = un(ji-2,jj,jk)135 uebnd(jj,jk,nib ,nit) = zucb *uemsk(jj,jk)136 uebnd(jj,jk,nibm ,nit) = zucbm *uemsk(jj,jk)137 uebnd(jj,jk,nibm2,nit) = zucbm2 *uemsk(jj,jk)138 END DO139 END DO140 END DO141 IF( lk_mpp ) CALL mppobc(uebnd,jpjed,jpjef,jpieob,jpk*3*3,2,jpj, numout )142 143 ! ... extremeties nie0, nie1144 ij = jpjed +1 - njmpp145 IF( ij >= 2 .AND. ij < jpjm1 ) THEN146 DO jk = 1,jpkm1147 uebnd(ij,jk,nibm,nitm) = uebnd(ij+1 ,jk,nibm,nitm)148 END DO149 END IF150 ij = jpjef +1 - njmpp151 IF( ij >= 2 .AND. ij < jpjm1 ) THEN152 DO jk = 1,jpkm1153 uebnd(ij,jk,nibm,nitm) = uebnd(ij-1 ,jk,nibm,nitm)154 END DO155 END IF156 157 ! 1.2 tangential velocity158 ! -----------------------159 160 ! ... advance in time (time filter, array swap)161 DO jk = 1, jpkm1162 DO jj = 1, jpj163 ! ... fields nitm2 <== nitm164 vebnd(jj,jk,nib ,nitm2) = vebnd(jj,jk,nib ,nitm)*vemsk(jj,jk)165 vebnd(jj,jk,nibm ,nitm2) = vebnd(jj,jk,nibm ,nitm)*vemsk(jj,jk)166 vebnd(jj,jk,nibm2,nitm2) = vebnd(jj,jk,nibm2,nitm)*vemsk(jj,jk)167 END DO168 END DO169 170 DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt.171 DO jk = 1, jpkm1172 DO jj = 1, jpj173 vebnd(jj,jk,nib ,nitm) = vebnd(jj,jk,nib, nit)*vemsk(jj,jk)174 vebnd(jj,jk,nibm ,nitm) = vebnd(jj,jk,nibm ,nit)*vemsk(jj,jk)175 vebnd(jj,jk,nibm2,nitm) = vebnd(jj,jk,nibm2,nit)*vemsk(jj,jk)176 ! ... fields nit <== now (kt+1)177 vebnd(jj,jk,nib ,nit) = vn(ji ,jj,jk)*vemsk(jj,jk)178 vebnd(jj,jk,nibm ,nit) = vn(ji-1,jj,jk)*vemsk(jj,jk)179 vebnd(jj,jk,nibm2,nit) = vn(ji-2,jj,jk)*vemsk(jj,jk)180 END DO181 END DO182 END DO183 IF( lk_mpp ) CALL mppobc(vebnd,jpjed,jpjef,jpieob+1,jpk*3*3,2,jpj, numout )184 185 !... extremeties nie0, nie1186 ij = jpjed +1 - njmpp187 IF( ij >= 2 .AND. ij < jpjm1 ) THEN188 DO jk = 1,jpkm1189 vebnd(ij,jk,nibm,nitm) = vebnd(ij+1 ,jk,nibm,nitm)190 END DO191 END IF192 ij = jpjef +1 - njmpp193 IF( ij >= 2 .AND. ij < jpjm1 ) THEN194 DO jk = 1,jpkm1195 vebnd(ij,jk,nibm,nitm) = vebnd(ij-1 ,jk,nibm,nitm)196 END DO197 END IF198 199 ! 1.3 Temperature and salinity200 ! ----------------------------201 202 ! ... advance in time (time filter, array swap)203 DO jk = 1, jpkm1204 DO jj = 1, jpj205 ! ... fields nitm <== nit plus time filter at the boundary206 tebnd(jj,jk,nib,nitm) = tebnd(jj,jk,nib,nit)*temsk(jj,jk)207 sebnd(jj,jk,nib,nitm) = sebnd(jj,jk,nib,nit)*temsk(jj,jk)208 END DO209 END DO210 211 DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt.212 DO jk = 1, jpkm1213 DO jj = 1, jpj214 tebnd(jj,jk,nibm,nitm) = tebnd(jj,jk,nibm,nit)*temsk(jj,jk)215 sebnd(jj,jk,nibm,nitm) = sebnd(jj,jk,nibm,nit)*temsk(jj,jk)216 ! ... fields nit <== now (kt+1)217 tebnd(jj,jk,nib ,nit) = tn(ji ,jj,jk)*temsk(jj,jk)218 tebnd(jj,jk,nibm ,nit) = tn(ji-1,jj,jk)*temsk(jj,jk)219 sebnd(jj,jk,nib ,nit) = sn(ji ,jj,jk)*temsk(jj,jk)220 sebnd(jj,jk,nibm ,nit) = sn(ji-1,jj,jk)*temsk(jj,jk)221 END DO222 END DO223 END DO224 IF( lk_mpp ) CALL mppobc(tebnd,jpjed,jpjef,jpieob+1,jpk*2*2,2,jpj, numout )225 IF( lk_mpp ) CALL mppobc(sebnd,jpjed,jpjef,jpieob+1,jpk*2*2,2,jpj, numout )226 227 ! ... extremeties nie0, nie1228 ij = jpjed +1 - njmpp229 IF( ij >= 2 .AND. ij < jpjm1 ) THEN230 DO jk = 1,jpkm1231 tebnd(ij,jk,nibm,nitm) = tebnd(ij+1 ,jk,nibm,nitm)232 sebnd(ij,jk,nibm,nitm) = sebnd(ij+1 ,jk,nibm,nitm)233 END DO234 END IF235 ij = jpjef +1 - njmpp236 IF( ij >= 2 .AND. ij < jpjm1 ) THEN237 DO jk = 1,jpkm1238 tebnd(ij,jk,nibm,nitm) = tebnd(ij-1 ,jk,nibm,nitm)239 sebnd(ij,jk,nibm,nitm) = sebnd(ij-1 ,jk,nibm,nitm)240 END DO241 END IF242 243 END IF ! End of array swap244 245 ! 2 - Calculation of radiation velocities246 ! ---------------------------------------247 248 IF( kt >= nit000 +3 .OR. ln_rstart ) THEN249 250 ! 2.1 Calculate the normal velocity U based on phase velocity u_cxebnd251 ! ---------------------------------------------------------------------252 !253 ! nibm2 nibm nib254 ! | nibm | nib |///255 ! | | | | |///256 ! jj-line --f----v----f----v----f---257 ! | | | | |///258 ! | | |///259 ! jj-line u T u T u///260 ! | | |///261 ! | | | | |///262 ! jpieob-2 jpieob-1 jpieob263 ! | |264 ! jpieob-1 jpieob265 !266 ! ... (jpjedp1, jpjefm1),jpieob267 DO ji = fs_nie0, fs_nie1 ! Vector opt.268 DO jk = 1, jpkm1269 DO jj = 2, jpjm1270 ! ... 2* gradi(u) (T-point i=nibm, time mean)271 z2dx = ( uebnd(jj,jk,nibm ,nit) + uebnd(jj,jk,nibm ,nitm2) &272 - 2.*uebnd(jj,jk,nibm2,nitm) ) / e1t(ji-1,jj)273 ! ... 2* gradj(u) (u-point i=nibm, time nitm)274 z2dy = ( uebnd(jj+1,jk,nibm,nitm) - uebnd(jj-1,jk,nibm,nitm) ) / e2u(ji-1,jj)275 ! ... square of the norm of grad(u)276 z4nor2 = z2dx * z2dx + z2dy * z2dy277 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt278 zdt = uebnd(jj,jk,nibm,nitm2) - uebnd(jj,jk,nibm,nit)279 ! ... i-phase speed ratio (bounded by 1)280 IF( z4nor2 == 0. ) THEN281 z4nor2=.00001282 END IF283 z05cx = zdt * z2dx / z4nor2284 u_cxebnd(jj,jk) = z05cx*uemsk(jj,jk)285 END DO286 END DO287 END DO288 289 ! 2.2 Calculate the tangential velocity based on phase velocity v_cxebnd290 ! -----------------------------------------------------------------------291 !292 ! nibm2 nibm nib293 ! | nibm | nib///|///294 ! | | | |////|///295 ! jj-line --v----f----v----f----v---296 ! | | | |////|///297 ! | | | |////|///298 ! | jpieob-1| jpieob /|///299 ! | | |300 ! jpieob-1 jpieob jpieob+1301 !302 ! ... (jpjedp1, jpjefm1), jpieob+1303 DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt.304 DO jk = 1, jpkm1305 DO jj = 2, jpjm1306 ! ... 2* i-gradient of v (f-point i=nibm, time mean)307 z2dx = ( vebnd(jj,jk,nibm ,nit) + vebnd(jj,jk,nibm ,nitm2) &308 - 2.*vebnd(jj,jk,nibm2,nitm) ) / e1f(ji-2,jj)309 ! ... 2* j-gradient of v (v-point i=nibm, time nitm)310 z2dy = ( vebnd(jj+1,jk,nibm,nitm) - vebnd(jj-1,jk,nibm,nitm) ) / e2v(ji-1,jj)311 ! ... square of the norm of grad(v)312 z4nor2 = z2dx * z2dx + z2dy * z2dy313 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt314 zdt = vebnd(jj,jk,nibm,nitm2) - vebnd(jj,jk,nibm,nit)315 ! ... i-phase speed ratio (bounded by 1) and save the unbounded phase316 ! velocity ratio no divided by e1f for the tracer radiation317 IF( z4nor2 == 0. ) THEN318 z4nor2=.000001319 END IF320 z05cx = zdt * z2dx / z4nor2321 v_cxebnd(jj,jk) = z05cx*vemsk(jj,jk)322 END DO323 END DO324 END DO325 IF( lk_mpp ) CALL mppobc(v_cxebnd,jpjed,jpjef,jpieob+1,jpk,2,jpj, numout )326 327 ! ... extremeties nie0, nie1328 ij = jpjed +1 - njmpp329 IF( ij >= 2 .AND. ij < jpjm1 ) THEN330 DO jk = 1,jpkm1331 v_cxebnd(ij,jk) = v_cxebnd(ij+1 ,jk)332 END DO333 END IF334 ij = jpjef +1 - njmpp335 IF( ij >= 2 .AND. ij < jpjm1 ) THEN336 DO jk = 1,jpkm1337 v_cxebnd(ij,jk) = v_cxebnd(ij-1 ,jk)338 END DO339 END IF340 341 END IF342 343 END SUBROUTINE obc_rad_east344 345 346 SUBROUTINE obc_rad_west ( kt )347 !!------------------------------------------------------------------------------348 !! *** SUBROUTINE obc_rad_west ***349 !!350 !! ** Purpose :351 !! Perform swap of arrays to calculate radiative phase speeds at the open352 !! west boundary and calculate those phase speeds if this OBC is not fixed.353 !! In case of fixed OBC, this subrountine is not called.354 !!355 !! History :356 !! ! 95-03 (J.-M. Molines) Original from SPEM357 !! ! 97-07 (G. Madec, J.-M. Molines) additions358 !! ! 97-12 (M. Imbard) Mpp adaptation359 !! ! 00-06 (J.-M. Molines)360 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90361 !!------------------------------------------------------------------------------362 !! * Arguments363 INTEGER, INTENT( in ) :: kt364 365 !! * Local declarations366 INTEGER :: ij367 REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy368 REAL(wp) :: zucb, zucbm, zucbm2369 !!------------------------------------------------------------------------------370 371 ! 1. Swap arrays before calculating radiative velocities372 ! ------------------------------------------------------373 374 ! 1.1 zonal velocity375 ! -------------------376 377 IF( kt > nit000 .OR. ln_rstart ) THEN378 379 ! ... advance in time (time filter, array swap)380 DO jk = 1, jpkm1381 DO jj = 1, jpj382 uwbnd(jj,jk,nib ,nitm2) = uwbnd(jj,jk,nib ,nitm)*uwmsk(jj,jk)383 uwbnd(jj,jk,nibm ,nitm2) = uwbnd(jj,jk,nibm ,nitm)*uwmsk(jj,jk)384 uwbnd(jj,jk,nibm2,nitm2) = uwbnd(jj,jk,nibm2,nitm)*uwmsk(jj,jk)385 END DO386 END DO387 388 ! ... fields nitm <== nit plus time filter at the boundary389 DO ji = fs_niw0, fs_niw1 ! Vector opt.390 DO jk = 1, jpkm1391 DO jj = 1, jpj392 uwbnd(jj,jk,nib ,nitm) = uwbnd(jj,jk,nib ,nit)*uwmsk(jj,jk)393 uwbnd(jj,jk,nibm ,nitm) = uwbnd(jj,jk,nibm ,nit)*uwmsk(jj,jk)394 uwbnd(jj,jk,nibm2,nitm) = uwbnd(jj,jk,nibm2,nit)*uwmsk(jj,jk)395 ! ... total or baroclinic velocity at b, bm and bm2396 zucb = un (ji,jj,jk)397 zucbm = un (ji+1,jj,jk)398 zucbm2 = un (ji+2,jj,jk)399 400 ! ... fields nit <== now (kt+1)401 uwbnd(jj,jk,nib ,nit) = zucb *uwmsk(jj,jk)402 uwbnd(jj,jk,nibm ,nit) = zucbm *uwmsk(jj,jk)403 uwbnd(jj,jk,nibm2,nit) = zucbm2*uwmsk(jj,jk)404 END DO405 END DO406 END DO407 IF( lk_mpp ) CALL mppobc(uwbnd,jpjwd,jpjwf,jpiwob,jpk*3*3,2,jpj, numout )408 409 ! ... extremeties niw0, niw1410 ij = jpjwd +1 - njmpp411 IF( ij >= 2 .AND. ij < jpjm1 ) THEN412 DO jk = 1,jpkm1413 uwbnd(ij,jk,nibm,nitm) = uwbnd(ij+1 ,jk,nibm,nitm)414 END DO415 END IF416 ij = jpjwf +1 - njmpp417 IF( ij >= 2 .AND. ij < jpjm1 ) THEN418 DO jk = 1,jpkm1419 uwbnd(ij,jk,nibm,nitm) = uwbnd(ij-1 ,jk,nibm,nitm)420 END DO421 END IF422 423 ! 1.2 tangential velocity424 ! -----------------------425 426 ! ... advance in time (time filter, array swap)427 DO jk = 1, jpkm1428 DO jj = 1, jpj429 ! ... fields nitm2 <== nitm430 vwbnd(jj,jk,nib ,nitm2) = vwbnd(jj,jk,nib ,nitm)*vwmsk(jj,jk)431 vwbnd(jj,jk,nibm ,nitm2) = vwbnd(jj,jk,nibm ,nitm)*vwmsk(jj,jk)432 vwbnd(jj,jk,nibm2,nitm2) = vwbnd(jj,jk,nibm2,nitm)*vwmsk(jj,jk)433 END DO434 END DO435 436 DO ji = fs_niw0, fs_niw1 ! Vector opt.437 DO jk = 1, jpkm1438 DO jj = 1, jpj439 vwbnd(jj,jk,nib ,nitm) = vwbnd(jj,jk,nib, nit)*vwmsk(jj,jk)440 vwbnd(jj,jk,nibm ,nitm) = vwbnd(jj,jk,nibm ,nit)*vwmsk(jj,jk)441 vwbnd(jj,jk,nibm2,nitm) = vwbnd(jj,jk,nibm2,nit)*vwmsk(jj,jk)442 ! ... fields nit <== now (kt+1)443 vwbnd(jj,jk,nib ,nit) = vn(ji ,jj,jk)*vwmsk(jj,jk)444 vwbnd(jj,jk,nibm ,nit) = vn(ji+1,jj,jk)*vwmsk(jj,jk)445 vwbnd(jj,jk,nibm2,nit) = vn(ji+2,jj,jk)*vwmsk(jj,jk)446 END DO447 END DO448 END DO449 IF( lk_mpp ) CALL mppobc(vwbnd,jpjwd,jpjwf,jpiwob,jpk*3*3,2,jpj, numout )450 451 ! ... extremeties niw0, niw1452 ij = jpjwd +1 - njmpp453 IF( ij >= 2 .AND. ij < jpjm1 ) THEN454 DO jk = 1,jpkm1455 vwbnd(ij,jk,nibm,nitm) = vwbnd(ij+1 ,jk,nibm,nitm)456 END DO457 END IF458 ij = jpjwf +1 - njmpp459 IF( ij >= 2 .AND. ij < jpjm1 ) THEN460 DO jk = 1,jpkm1461 vwbnd(ij,jk,nibm,nitm) = vwbnd(ij-1 ,jk,nibm,nitm)462 END DO463 END IF464 465 ! 1.3 Temperature and salinity466 ! ----------------------------467 468 ! ... advance in time (time filter, array swap)469 DO jk = 1, jpkm1470 DO jj = 1, jpj471 ! ... fields nitm <== nit plus time filter at the boundary472 twbnd(jj,jk,nib,nitm) = twbnd(jj,jk,nib,nit)*twmsk(jj,jk)473 swbnd(jj,jk,nib,nitm) = swbnd(jj,jk,nib,nit)*twmsk(jj,jk)474 END DO475 END DO476 477 DO ji = fs_niw0, fs_niw1 ! Vector opt.478 DO jk = 1, jpkm1479 DO jj = 1, jpj480 twbnd(jj,jk,nibm ,nitm) = twbnd(jj,jk,nibm ,nit)*twmsk(jj,jk)481 swbnd(jj,jk,nibm ,nitm) = swbnd(jj,jk,nibm ,nit)*twmsk(jj,jk)482 ! ... fields nit <== now (kt+1)483 twbnd(jj,jk,nib ,nit) = tn(ji ,jj,jk)*twmsk(jj,jk)484 twbnd(jj,jk,nibm ,nit) = tn(ji+1 ,jj,jk)*twmsk(jj,jk)485 swbnd(jj,jk,nib ,nit) = sn(ji ,jj,jk)*twmsk(jj,jk)486 swbnd(jj,jk,nibm ,nit) = sn(ji+1 ,jj,jk)*twmsk(jj,jk)487 END DO488 END DO489 END DO490 IF( lk_mpp ) CALL mppobc(twbnd,jpjwd,jpjwf,jpiwob,jpk*2*2,2,jpj, numout )491 IF( lk_mpp ) CALL mppobc(swbnd,jpjwd,jpjwf,jpiwob,jpk*2*2,2,jpj, numout )492 493 ! ... extremeties niw0, niw1494 ij = jpjwd +1 - njmpp495 IF( ij >= 2 .AND. ij < jpjm1 ) THEN496 DO jk = 1,jpkm1497 twbnd(ij,jk,nibm,nitm) = twbnd(ij+1 ,jk,nibm,nitm)498 swbnd(ij,jk,nibm,nitm) = swbnd(ij+1 ,jk,nibm,nitm)499 END DO500 END IF501 ij = jpjwf +1 - njmpp502 IF( ij >= 2 .AND. ij < jpjm1 ) THEN503 DO jk = 1,jpkm1504 twbnd(ij,jk,nibm,nitm) = twbnd(ij-1 ,jk,nibm,nitm)505 swbnd(ij,jk,nibm,nitm) = swbnd(ij-1 ,jk,nibm,nitm)506 END DO507 END IF508 509 END IF ! End of array swap510 511 ! 2 - Calculation of radiation velocities512 ! ---------------------------------------513 514 IF( kt >= nit000 +3 .OR. ln_rstart ) THEN515 516 ! 2.1 Calculate the normal velocity U based on phase velocity u_cxwbnd517 ! ----------------------------------------------------------------------518 !519 ! nib nibm nibm2520 ! ///| nib | nibm |521 ! ///| | | | |522 ! ---f----v----f----v----f-- jj-line523 ! ///| | | | |524 ! ///| | |525 ! ///u T u T u jj-line526 ! ///| | |527 ! ///| | | | |528 ! jpiwob jpiwob+1 jpiwob+2529 ! | |530 ! jpiwob+1 jpiwob+2531 !532 ! ... If free surface formulation:533 ! ... radiative conditions on the total part + relaxation toward climatology534 ! ... (jpjwdp1, jpjwfm1), jpiwob535 DO ji = fs_niw0, fs_niw1 ! Vector opt.536 DO jk = 1, jpkm1537 DO jj = 2, jpjm1538 ! ... 2* gradi(u) (T-point i=nibm, time mean)539 z2dx = ( - uwbnd(jj,jk,nibm ,nit) - uwbnd(jj,jk,nibm ,nitm2) &540 + 2.*uwbnd(jj,jk,nibm2,nitm) ) / e1t(ji+2,jj)541 ! ... 2* gradj(u) (u-point i=nibm, time nitm)542 z2dy = ( uwbnd(jj+1,jk,nibm,nitm) - uwbnd(jj-1,jk,nibm,nitm) ) / e2u(ji+1,jj)543 ! ... square of the norm of grad(u)544 z4nor2 = z2dx * z2dx + z2dy * z2dy545 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt546 zdt = uwbnd(jj,jk,nibm,nitm2) - uwbnd(jj,jk,nibm,nit)547 ! ... i-phase speed ratio (bounded by -1)548 IF( z4nor2 == 0. ) THEN549 z4nor2=0.00001550 END IF551 z05cx = zdt * z2dx / z4nor2552 u_cxwbnd(jj,jk)=z05cx*uwmsk(jj,jk)553 END DO554 END DO555 END DO556 557 ! 2.2 Calculate the tangential velocity based on phase velocity v_cxwbnd558 ! -----------------------------------------------------------------------559 !560 ! nib nibm nibm2561 ! ///|///nib | nibm | nibm2562 ! ///|////| | | | | |563 ! ---v----f----v----f----v----f----v-- jj-line564 ! ///|////| | | | | |565 ! ///|////| | | | | |566 ! jpiwob jpiwob+1 jpiwob+2567 ! | | |568 ! jpiwob jpiwob+1 jpiwob+2569 !570 ! ... radiative condition plus Raymond-Kuo571 ! ... (jpjwdp1, jpjwfm1),jpiwob572 DO ji = fs_niw0, fs_niw1 ! Vector opt.573 DO jk = 1, jpkm1574 DO jj = 2, jpjm1575 ! ... 2* i-gradient of v (f-point i=nibm, time mean)576 z2dx = ( - vwbnd(jj,jk,nibm ,nit) - vwbnd(jj,jk,nibm ,nitm2) &577 + 2.*vwbnd(jj,jk,nibm2,nitm) ) / e1f(ji+1,jj)578 ! ... 2* j-gradient of v (v-point i=nibm, time nitm)579 z2dy = ( vwbnd(jj+1,jk,nibm,nitm) - vwbnd(jj-1,jk,nibm,nitm) ) / e2v(ji+1,jj)580 ! ... square of the norm of grad(v)581 z4nor2 = z2dx * z2dx + z2dy * z2dy582 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt583 zdt = vwbnd(jj,jk,nibm,nitm2) - vwbnd(jj,jk,nibm,nit)584 ! ... i-phase speed ratio (bounded by -1) and save the unbounded phase585 ! velocity ratio no divided by e1f for the tracer radiation586 IF( z4nor2 == 0) THEN587 z4nor2=0.000001588 endif589 z05cx = zdt * z2dx / z4nor2590 v_cxwbnd(jj,jk) = z05cx*vwmsk(jj,jk)591 END DO592 END DO593 END DO594 IF( lk_mpp ) CALL mppobc(v_cxwbnd,jpjwd,jpjwf,jpiwob,jpk,2,jpj, numout )595 596 ! ... extremeties niw0, niw1597 ij = jpjwd +1 - njmpp598 IF( ij >= 2 .AND. ij < jpjm1 ) THEN599 DO jk = 1,jpkm1600 v_cxwbnd(ij,jk) = v_cxwbnd(ij+1 ,jk)601 END DO602 END IF603 ij = jpjwf +1 - njmpp604 IF( ij >= 2 .AND. ij < jpjm1 ) THEN605 DO jk = 1,jpkm1606 v_cxwbnd(ij,jk) = v_cxwbnd(ij-1 ,jk)607 END DO608 END IF609 610 END IF611 612 END SUBROUTINE obc_rad_west613 614 615 SUBROUTINE obc_rad_north ( kt )616 !!------------------------------------------------------------------------------617 !! *** SUBROUTINE obc_rad_north ***618 !!619 !! ** Purpose :620 !! Perform swap of arrays to calculate radiative phase speeds at the open621 !! north boundary and calculate those phase speeds if this OBC is not fixed.622 !! In case of fixed OBC, this subrountine is not called.623 !!624 !! History :625 !! ! 95-03 (J.-M. Molines) Original from SPEM626 !! ! 97-07 (G. Madec, J.-M. Molines) additions627 !! ! 97-12 (M. Imbard) Mpp adaptation628 !! ! 00-06 (J.-M. Molines)629 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90630 !!------------------------------------------------------------------------------631 !! * Arguments632 INTEGER, INTENT( in ) :: kt633 634 !! * Local declarations635 INTEGER :: ii636 REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy637 REAL(wp) :: zvcb, zvcbm, zvcbm2638 !!------------------------------------------------------------------------------639 640 ! 1. Swap arrays before calculating radiative velocities641 ! ------------------------------------------------------642 643 ! 1.1 zonal velocity644 ! -------------------645 646 IF( kt > nit000 .OR. ln_rstart ) THEN647 648 ! ... advance in time (time filter, array swap)649 DO jk = 1, jpkm1650 DO ji = 1, jpi651 ! ... fields nitm2 <== nitm652 unbnd(ji,jk,nib ,nitm2) = unbnd(ji,jk,nib ,nitm)*unmsk(ji,jk)653 unbnd(ji,jk,nibm ,nitm2) = unbnd(ji,jk,nibm ,nitm)*unmsk(ji,jk)654 unbnd(ji,jk,nibm2,nitm2) = unbnd(ji,jk,nibm2,nitm)*unmsk(ji,jk)655 END DO656 END DO657 658 DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt.659 DO jk = 1, jpkm1660 DO ji = 1, jpi661 unbnd(ji,jk,nib ,nitm) = unbnd(ji,jk,nib, nit)*unmsk(ji,jk)662 unbnd(ji,jk,nibm ,nitm) = unbnd(ji,jk,nibm ,nit)*unmsk(ji,jk)663 unbnd(ji,jk,nibm2,nitm) = unbnd(ji,jk,nibm2,nit)*unmsk(ji,jk)664 ! ... fields nit <== now (kt+1)665 unbnd(ji,jk,nib ,nit) = un(ji,jj, jk)*unmsk(ji,jk)666 unbnd(ji,jk,nibm ,nit) = un(ji,jj-1,jk)*unmsk(ji,jk)667 unbnd(ji,jk,nibm2,nit) = un(ji,jj-2,jk)*unmsk(ji,jk)668 END DO669 END DO670 END DO671 IF( lk_mpp ) CALL mppobc(unbnd,jpind,jpinf,jpjnob+1,jpk*3*3,1,jpi, numout )672 673 ! ... extremeties njn0,njn1674 ii = jpind + 1 - nimpp675 IF( ii >= 2 .AND. ii < jpim1 ) THEN676 DO jk = 1, jpkm1677 unbnd(ii,jk,nibm,nitm) = unbnd(ii+1,jk,nibm,nitm)678 END DO679 END IF680 ii = jpinf + 1 - nimpp681 IF( ii >= 2 .AND. ii < jpim1 ) THEN682 DO jk = 1, jpkm1683 unbnd(ii,jk,nibm,nitm) = unbnd(ii-1,jk,nibm,nitm)684 END DO685 END IF686 687 ! 1.2. normal velocity688 ! --------------------689 690 ! ... advance in time (time filter, array swap)691 DO jk = 1, jpkm1692 DO ji = 1, jpi693 ! ... fields nitm2 <== nitm694 vnbnd(ji,jk,nib ,nitm2) = vnbnd(ji,jk,nib ,nitm)*vnmsk(ji,jk)695 vnbnd(ji,jk,nibm ,nitm2) = vnbnd(ji,jk,nibm ,nitm)*vnmsk(ji,jk)696 vnbnd(ji,jk,nibm2,nitm2) = vnbnd(ji,jk,nibm2,nitm)*vnmsk(ji,jk)697 END DO698 END DO699 700 DO jj = fs_njn0, fs_njn1 ! Vector opt.701 DO jk = 1, jpkm1702 DO ji = 1, jpi703 vnbnd(ji,jk,nib ,nitm) = vnbnd(ji,jk,nib, nit)*vnmsk(ji,jk)704 vnbnd(ji,jk,nibm ,nitm) = vnbnd(ji,jk,nibm ,nit)*vnmsk(ji,jk)705 vnbnd(ji,jk,nibm2,nitm) = vnbnd(ji,jk,nibm2,nit)*vnmsk(ji,jk)706 ! ... fields nit <== now (kt+1)707 ! ... total or baroclinic velocity at b, bm and bm2708 zvcb = vn (ji,jj,jk)709 zvcbm = vn (ji,jj-1,jk)710 zvcbm2 = vn (ji,jj-2,jk)711 ! ... fields nit <== now (kt+1)712 vnbnd(ji,jk,nib ,nit) = zvcb *vnmsk(ji,jk)713 vnbnd(ji,jk,nibm ,nit) = zvcbm *vnmsk(ji,jk)714 vnbnd(ji,jk,nibm2,nit) = zvcbm2*vnmsk(ji,jk)715 END DO716 END DO717 END DO718 IF( lk_mpp ) CALL mppobc(vnbnd,jpind,jpinf,jpjnob,jpk*3*3,1,jpi, numout )719 720 ! ... extremeties njn0,njn1721 ii = jpind + 1 - nimpp722 IF( ii >= 2 .AND. ii < jpim1 ) THEN723 DO jk = 1, jpkm1724 vnbnd(ii,jk,nibm,nitm) = vnbnd(ii+1,jk,nibm,nitm)725 END DO726 END IF727 ii = jpinf + 1 - nimpp728 IF( ii >= 2 .AND. ii < jpim1 ) THEN729 DO jk = 1, jpkm1730 vnbnd(ii,jk,nibm,nitm) = vnbnd(ii-1,jk,nibm,nitm)731 END DO732 END IF733 734 ! 1.3 Temperature and salinity735 ! ----------------------------736 737 ! ... advance in time (time filter, array swap)738 DO jk = 1, jpkm1739 DO ji = 1, jpi740 ! ... fields nitm <== nit plus time filter at the boundary741 tnbnd(ji,jk,nib ,nitm) = tnbnd(ji,jk,nib,nit)*tnmsk(ji,jk)742 snbnd(ji,jk,nib ,nitm) = snbnd(ji,jk,nib,nit)*tnmsk(ji,jk)743 END DO744 END DO745 746 DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt.747 DO jk = 1, jpkm1748 DO ji = 1, jpi749 tnbnd(ji,jk,nibm ,nitm) = tnbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk)750 snbnd(ji,jk,nibm ,nitm) = snbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk)751 ! ... fields nit <== now (kt+1)752 tnbnd(ji,jk,nib ,nit) = tn(ji,jj, jk)*tnmsk(ji,jk)753 tnbnd(ji,jk,nibm ,nit) = tn(ji,jj-1,jk)*tnmsk(ji,jk)754 snbnd(ji,jk,nib ,nit) = sn(ji,jj, jk)*tnmsk(ji,jk)755 snbnd(ji,jk,nibm ,nit) = sn(ji,jj-1,jk)*tnmsk(ji,jk)756 END DO757 END DO758 END DO759 IF( lk_mpp ) CALL mppobc(tnbnd,jpind,jpinf,jpjnob+1,jpk*2*2,1,jpi, numout )760 IF( lk_mpp ) CALL mppobc(snbnd,jpind,jpinf,jpjnob+1,jpk*2*2,1,jpi, numout )761 762 ! ... extremeties njn0,njn1763 ii = jpind + 1 - nimpp764 IF( ii >= 2 .AND. ii < jpim1 ) THEN765 DO jk = 1, jpkm1766 tnbnd(ii,jk,nibm,nitm) = tnbnd(ii+1,jk,nibm,nitm)767 snbnd(ii,jk,nibm,nitm) = snbnd(ii+1,jk,nibm,nitm)768 END DO769 END IF770 ii = jpinf + 1 - nimpp771 IF( ii >= 2 .AND. ii < jpim1 ) THEN772 DO jk = 1, jpkm1773 tnbnd(ii,jk,nibm,nitm) = tnbnd(ii-1,jk,nibm,nitm)774 snbnd(ii,jk,nibm,nitm) = snbnd(ii-1,jk,nibm,nitm)775 END DO776 END IF777 778 END IF ! End of array swap779 780 ! 2 - Calculation of radiation velocities781 ! ---------------------------------------782 783 IF( kt >= nit000 +3 .OR. ln_rstart ) THEN784 785 ! 2.1 Calculate the normal velocity based on phase velocity u_cynbnd786 ! -------------------------------------------------------------------787 !788 ! ji-row789 ! |790 ! nib -///u////// jpjnob + 1791 ! /////|//////792 ! nib -----f----- jpjnob793 ! |794 ! nibm-- u ---- jpjnob795 ! |796 ! nibm -----f----- jpjnob-1797 ! |798 ! nibm2-- u ---- jpjnob-1799 ! |800 ! nibm2 -----f----- jpjnob-2801 ! |802 ! ... radiative condition803 ! ... jpjnob+1,(jpindp1, jpinfm1)804 DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt.805 DO jk = 1, jpkm1806 DO ji = 2, jpim1807 ! ... 2* j-gradient of u (f-point i=nibm, time mean)808 z2dx = ( unbnd(ji,jk,nibm ,nit) + unbnd(ji,jk,nibm ,nitm2) &809 - 2.*unbnd(ji,jk,nibm2,nitm)) / e2f(ji,jj-2)810 ! ... 2* i-gradient of u (u-point i=nibm, time nitm)811 z2dy = ( unbnd(ji+1,jk,nibm,nitm) - unbnd(ji-1,jk,nibm,nitm) ) / e1u(ji,jj-1)812 ! ... square of the norm of grad(v)813 z4nor2 = z2dx * z2dx + z2dy * z2dy814 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt815 zdt = unbnd(ji,jk,nibm,nitm2) - unbnd(ji,jk,nibm,nit)816 ! ... i-phase speed ratio (bounded by 1) and save the unbounded phase817 ! velocity ratio no divided by e1f for the tracer radiation818 IF( z4nor2 == 0.) THEN819 z4nor2=.000001820 END IF821 z05cx = zdt * z2dx / z4nor2822 u_cynbnd(ji,jk) = z05cx *unmsk(ji,jk)823 END DO824 END DO825 END DO826 IF( lk_mpp ) CALL mppobc(u_cynbnd,jpind,jpinf,jpjnob+1,jpk,1,jpi, numout )827 828 ! ... extremeties njn0,njn1829 ii = jpind + 1 - nimpp830 IF( ii >= 2 .AND. ii < jpim1 ) THEN831 DO jk = 1, jpkm1832 u_cynbnd(ii,jk) = u_cynbnd(ii+1,jk)833 END DO834 END IF835 ii = jpinf + 1 - nimpp836 IF( ii >= 2 .AND. ii < jpim1 ) THEN837 DO jk = 1, jpkm1838 u_cynbnd(ii,jk) = u_cynbnd(ii-1,jk)839 END DO840 END IF841 842 ! 2.2 Calculate the normal velocity based on phase velocity v_cynbnd843 ! ------------------------------------------------------------------844 !845 ! ji-row ji-row846 ! |847 ! /////|/////////////////848 ! nib -----f----v----f---- jpjnob849 ! | |850 ! nib - u -- T -- u ---- jpjnob851 ! | |852 ! nibm -----f----v----f---- jpjnob-1853 ! | |854 ! nibm -- u -- T -- u --- jpjnob-1855 ! | |856 ! nibm2 -----f----v----f---- jpjnob-2857 ! | |858 ! ... Free surface formulation:859 ! ... radiative conditions on the total part + relaxation toward climatology860 ! ... jpjnob,(jpindp1, jpinfm1)861 DO jj = fs_njn0, fs_njn1 ! Vector opt.862 DO jk = 1, jpkm1863 DO ji = 2, jpim1864 ! ... 2* gradj(v) (T-point i=nibm, time mean)865 ii = ji -1 + nimpp866 z2dx = ( vnbnd(ji,jk,nibm ,nit) + vnbnd(ji,jk,nibm ,nitm2) &867 - 2.*vnbnd(ji,jk,nibm2,nitm)) / e2t(ji,jj-1)868 ! ... 2* gradi(v) (v-point i=nibm, time nitm)869 z2dy = ( vnbnd(ji+1,jk,nibm,nitm) - vnbnd(ji-1,jk,nibm,nitm) ) / e1v(ji,jj-1)870 ! ... square of the norm of grad(u)871 z4nor2 = z2dx * z2dx + z2dy * z2dy872 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt873 zdt = vnbnd(ji,jk,nibm,nitm2) - vnbnd(ji,jk,nibm,nit)874 ! ... j-phase speed ratio (bounded by 1)875 IF( z4nor2 == 0. ) THEN876 z4nor2=.00001877 END IF878 z05cx = zdt * z2dx / z4nor2879 v_cynbnd(ji,jk)=z05cx *vnmsk(ji,jk)880 END DO881 END DO882 END DO883 884 END IF885 886 END SUBROUTINE obc_rad_north887 888 889 SUBROUTINE obc_rad_south ( kt )890 !!------------------------------------------------------------------------------891 !! *** SUBROUTINE obc_rad_south ***892 !!893 !! ** Purpose :894 !! Perform swap of arrays to calculate radiative phase speeds at the open895 !! south boundary and calculate those phase speeds if this OBC is not fixed.896 !! In case of fixed OBC, this subrountine is not called.897 !!898 !! History :899 !! ! 95-03 (J.-M. Molines) Original from SPEM900 !! ! 97-07 (G. Madec, J.-M. Molines) additions901 !! ! 97-12 (M. Imbard) Mpp adaptation902 !! ! 00-06 (J.-M. Molines)903 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90904 !!------------------------------------------------------------------------------905 !! * Arguments906 INTEGER, INTENT( in ) :: kt907 908 !! * Local declarations909 INTEGER :: ii910 REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy911 REAL(wp) :: zvcb, zvcbm, zvcbm2912 !!------------------------------------------------------------------------------913 914 ! 1. Swap arrays before calculating radiative velocities915 ! ------------------------------------------------------916 917 ! 1.1 zonal velocity918 ! --------------------919 920 IF( kt > nit000 .OR. ln_rstart ) THEN921 922 ! ... advance in time (time filter, array swap)923 DO jk = 1, jpkm1924 DO ji = 1, jpi925 ! ... fields nitm2 <== nitm926 usbnd(ji,jk,nib ,nitm2) = usbnd(ji,jk,nib ,nitm)*usmsk(ji,jk)927 usbnd(ji,jk,nibm ,nitm2) = usbnd(ji,jk,nibm ,nitm)*usmsk(ji,jk)928 usbnd(ji,jk,nibm2,nitm2) = usbnd(ji,jk,nibm2,nitm)*usmsk(ji,jk)929 END DO930 END DO931 932 DO jj = fs_njs0, fs_njs1 ! Vector opt.933 DO jk = 1, jpkm1934 DO ji = 1, jpi935 usbnd(ji,jk,nib ,nitm) = usbnd(ji,jk,nib, nit)*usmsk(ji,jk)936 usbnd(ji,jk,nibm ,nitm) = usbnd(ji,jk,nibm ,nit)*usmsk(ji,jk)937 usbnd(ji,jk,nibm2,nitm) = usbnd(ji,jk,nibm2,nit)*usmsk(ji,jk)938 ! ... fields nit <== now (kt+1)939 usbnd(ji,jk,nib ,nit) = un(ji,jj ,jk)*usmsk(ji,jk)940 usbnd(ji,jk,nibm ,nit) = un(ji,jj+1,jk)*usmsk(ji,jk)941 usbnd(ji,jk,nibm2,nit) = un(ji,jj+2,jk)*usmsk(ji,jk)942 END DO943 END DO944 END DO945 IF( lk_mpp ) CALL mppobc(usbnd,jpisd,jpisf,jpjsob,jpk*3*3,1,jpi, numout )946 947 ! ... extremeties njs0,njs1948 ii = jpisd + 1 - nimpp949 IF( ii >= 2 .AND. ii < jpim1 ) THEN950 DO jk = 1, jpkm1951 usbnd(ii,jk,nibm,nitm) = usbnd(ii+1,jk,nibm,nitm)952 END DO953 END IF954 ii = jpisf + 1 - nimpp955 IF( ii >= 2 .AND. ii < jpim1 ) THEN956 DO jk = 1, jpkm1957 usbnd(ii,jk,nibm,nitm) = usbnd(ii-1,jk,nibm,nitm)958 END DO959 END IF960 961 ! 1.2 normal velocity962 ! -------------------963 964 !.. advance in time (time filter, array swap)965 DO jk = 1, jpkm1966 DO ji = 1, jpi967 ! ... fields nitm2 <== nitm968 vsbnd(ji,jk,nib ,nitm2) = vsbnd(ji,jk,nib ,nitm)*vsmsk(ji,jk)969 vsbnd(ji,jk,nibm ,nitm2) = vsbnd(ji,jk,nibm ,nitm)*vsmsk(ji,jk)970 END DO971 END DO972 973 DO jj = fs_njs0, fs_njs1 ! Vector opt.974 DO jk = 1, jpkm1975 DO ji = 1, jpi976 vsbnd(ji,jk,nib ,nitm) = vsbnd(ji,jk,nib, nit)*vsmsk(ji,jk)977 vsbnd(ji,jk,nibm ,nitm) = vsbnd(ji,jk,nibm ,nit)*vsmsk(ji,jk)978 vsbnd(ji,jk,nibm2,nitm) = vsbnd(ji,jk,nibm2,nit)*vsmsk(ji,jk)979 ! ... total or baroclinic velocity at b, bm and bm2980 zvcb = vn (ji,jj,jk)981 zvcbm = vn (ji,jj+1,jk)982 zvcbm2 = vn (ji,jj+2,jk)983 ! ... fields nit <== now (kt+1)984 vsbnd(ji,jk,nib ,nit) = zvcb *vsmsk(ji,jk)985 vsbnd(ji,jk,nibm ,nit) = zvcbm *vsmsk(ji,jk)986 vsbnd(ji,jk,nibm2,nit) = zvcbm2 *vsmsk(ji,jk)987 END DO988 END DO989 END DO990 IF( lk_mpp ) CALL mppobc(vsbnd,jpisd,jpisf,jpjsob,jpk*3*3,1,jpi, numout )991 992 ! ... extremeties njs0,njs1993 ii = jpisd + 1 - nimpp994 IF( ii >= 2 .AND. ii < jpim1 ) THEN995 DO jk = 1, jpkm1996 vsbnd(ii,jk,nibm,nitm) = vsbnd(ii+1,jk,nibm,nitm)997 END DO998 END IF999 ii = jpisf + 1 - nimpp1000 IF( ii >= 2 .AND. ii < jpim1 ) THEN1001 DO jk = 1, jpkm11002 vsbnd(ii,jk,nibm,nitm) = vsbnd(ii-1,jk,nibm,nitm)1003 END DO1004 END IF1005 1006 ! 1.3 Temperature and salinity1007 ! ----------------------------1008 1009 ! ... advance in time (time filter, array swap)1010 DO jk = 1, jpkm11011 DO ji = 1, jpi1012 ! ... fields nitm <== nit plus time filter at the boundary1013 tsbnd(ji,jk,nib,nitm) = tsbnd(ji,jk,nib,nit)*tsmsk(ji,jk)1014 ssbnd(ji,jk,nib,nitm) = ssbnd(ji,jk,nib,nit)*tsmsk(ji,jk)1015 END DO1016 END DO1017 1018 DO jj = fs_njs0, fs_njs1 ! Vector opt.1019 DO jk = 1, jpkm11020 DO ji = 1, jpi1021 tsbnd(ji,jk,nibm ,nitm) = tsbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk)1022 ssbnd(ji,jk,nibm ,nitm) = ssbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk)1023 ! ... fields nit <== now (kt+1)1024 tsbnd(ji,jk,nib ,nit) = tn(ji,jj ,jk)*tsmsk(ji,jk)1025 tsbnd(ji,jk,nibm ,nit) = tn(ji,jj+1 ,jk)*tsmsk(ji,jk)1026 ssbnd(ji,jk,nib ,nit) = sn(ji,jj ,jk)*tsmsk(ji,jk)1027 ssbnd(ji,jk,nibm ,nit) = sn(ji,jj+1 ,jk)*tsmsk(ji,jk)1028 END DO1029 END DO1030 END DO1031 IF( lk_mpp ) CALL mppobc(tsbnd,jpisd,jpisf,jpjsob,jpk*2*2,1,jpi, numout )1032 IF( lk_mpp ) CALL mppobc(ssbnd,jpisd,jpisf,jpjsob,jpk*2*2,1,jpi, numout )1033 1034 ! ... extremeties njs0,njs11035 ii = jpisd + 1 - nimpp1036 IF( ii >= 2 .AND. ii < jpim1 ) THEN1037 DO jk = 1, jpkm11038 tsbnd(ii,jk,nibm,nitm) = tsbnd(ii+1,jk,nibm,nitm)1039 ssbnd(ii,jk,nibm,nitm) = ssbnd(ii+1,jk,nibm,nitm)1040 END DO1041 END IF1042 ii = jpisf + 1 - nimpp1043 IF( ii >= 2 .AND. ii < jpim1 ) THEN1044 DO jk = 1, jpkm11045 tsbnd(ii,jk,nibm,nitm) = tsbnd(ii-1,jk,nibm,nitm)1046 ssbnd(ii,jk,nibm,nitm) = ssbnd(ii-1,jk,nibm,nitm)1047 END DO1048 END IF1049 1050 END IF ! End of array swap1051 1052 ! 2 - Calculation of radiation velocities1053 ! ---------------------------------------1054 1055 IF( kt >= nit000 +3 .OR. ln_rstart ) THEN1056 1057 ! 2.1 Calculate the normal velocity based on phase velocity u_cysbnd1058 ! -------------------------------------------------------------------1059 !1060 ! ji-row1061 ! |1062 ! nibm2 -----f----- jpjsob +21063 ! |1064 ! nibm2 -- u ----- jpjsob +21065 ! |1066 ! nibm -----f----- jpjsob +11067 ! |1068 ! nibm -- u ----- jpjsob +11069 ! |1070 ! nib -----f----- jpjsob1071 ! /////|//////1072 ! nib ////u///// jpjsob1073 !1074 ! ... radiative condition plus Raymond-Kuo1075 ! ... jpjsob,(jpisdp1, jpisfm1)1076 DO jj = fs_njs0, fs_njs1 ! Vector opt.1077 DO jk = 1, jpkm11078 DO ji = 2, jpim11079 ! ... 2* j-gradient of u (f-point i=nibm, time mean)1080 z2dx = (- usbnd(ji,jk,nibm ,nit) - usbnd(ji,jk,nibm ,nitm2) &1081 + 2.*usbnd(ji,jk,nibm2,nitm) ) / e2f(ji,jj+1)1082 ! ... 2* i-gradient of u (u-point i=nibm, time nitm)1083 z2dy = ( usbnd(ji+1,jk,nibm,nitm) - usbnd(ji-1,jk,nibm,nitm) ) / e1u(ji, jj+1)1084 ! ... square of the norm of grad(v)1085 z4nor2 = z2dx * z2dx + z2dy * z2dy1086 IF( z4nor2 == 0.) THEN1087 z4nor2 = 0.0000011088 END IF1089 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt1090 zdt = usbnd(ji,jk,nibm,nitm2) - usbnd(ji,jk,nibm,nit)1091 ! ... i-phase speed ratio (bounded by -1) and save the unbounded phase1092 ! velocity ratio no divided by e1f for the tracer radiation1093 z05cx = zdt * z2dx / z4nor21094 u_cysbnd(ji,jk) = z05cx*usmsk(ji,jk)1095 END DO1096 END DO1097 END DO1098 IF( lk_mpp ) CALL mppobc(u_cysbnd,jpisd,jpisf,jpjsob,jpk,1,jpi, numout )1099 1100 ! ... extremeties njs0,njs11101 ii = jpisd + 1 - nimpp1102 IF( ii >= 2 .AND. ii < jpim1 ) THEN1103 DO jk = 1, jpkm11104 u_cysbnd(ii,jk) = u_cysbnd(ii+1,jk)1105 END DO1106 END IF1107 ii = jpisf + 1 - nimpp1108 IF( ii >= 2 .AND. ii < jpim1 ) THEN1109 DO jk = 1, jpkm11110 u_cysbnd(ii,jk) = u_cysbnd(ii-1,jk)1111 END DO1112 END IF1113 1114 ! 2.2 Calculate the normal velocity based on phase velocity v_cysbnd1115 ! -------------------------------------------------------------------1116 !1117 ! ji-row ji-row1118 ! | |1119 ! nibm2 -----f----v----f---- jpjsob+21120 ! | |1121 ! nibm - u -- T -- u ---- jpjsob+21122 ! | |1123 ! nibm -----f----v----f---- jpjsob+11124 ! | |1125 ! nib -- u -- T -- u --- jpjsob+11126 ! | |1127 ! nib -----f----v----f---- jpjsob1128 ! /////////////////////1129 !1130 ! ... Free surface formulation:1131 ! ... radiative conditions on the total part + relaxation toward climatology1132 ! ... jpjsob,(jpisdp1,jpisfm1)1133 DO jj = fs_njs0, fs_njs1 ! Vector opt.1134 DO jk = 1, jpkm11135 DO ji = 2, jpim11136 ! ... 2* gradj(v) (T-point i=nibm, time mean)1137 z2dx = ( - vsbnd(ji,jk,nibm ,nit) - vsbnd(ji,jk,nibm ,nitm2) &1138 + 2.*vsbnd(ji,jk,nibm2,nitm) ) / e2t(ji,jj+1)1139 ! ... 2* gradi(v) (v-point i=nibm, time nitm)1140 z2dy = ( vsbnd(ji+1,jk,nibm,nitm) - vsbnd(ji-1,jk,nibm,nitm) ) / e1v(ji,jj+1)1141 ! ... square of the norm of grad(u)1142 z4nor2 = z2dx * z2dx + z2dy * z2dy1143 IF( z4nor2 == 0.) THEN1144 z4nor2 = 0.0000011145 END IF1146 ! ... minus time derivative (leap-frog) at nibm, without / 2 dt1147 zdt = vsbnd(ji,jk,nibm,nitm2) - vsbnd(ji,jk,nibm,nit)1148 ! ... j-phase speed ratio (bounded by -1)1149 z05cx = zdt * z2dx / z4nor21150 v_cysbnd(ji,jk)=z05cx*vsmsk(ji,jk)1151 END DO1152 END DO1153 END DO1154 1155 ENDIF1156 1157 END SUBROUTINE obc_rad_south1158 1159 #else7 !!$ !!--------------------------------------------------------------------------------- 8 !!$ !! obc_rad : call the subroutine for each open boundary 9 !!$ !! obc_rad_east : compute the east phase velocities 10 !!$ !! obc_rad_west : compute the west phase velocities 11 !!$ !! obc_rad_north : compute the north phase velocities 12 !!$ !! obc_rad_south : compute the south phase velocities 13 !!$ !!--------------------------------------------------------------------------------- 14 !!$ USE oce ! ocean dynamics and tracers variables 15 !!$ USE dom_oce ! ocean space and time domain variables 16 !!$ USE lbclnk ! ocean lateral boundary conditions (or mpp link) 17 !!$ USE phycst ! physical constants 18 !!$ USE obc_oce ! ocean open boundary conditions 19 !!$ USE lib_mpp ! for mppobc 20 !!$ USE in_out_manager ! I/O units 21 !!$ 22 !!$ IMPLICIT NONE 23 !!$ PRIVATE 24 !!$ 25 !!$ PUBLIC obc_rad ! routine called by step.F90 26 !!$ 27 !!$ INTEGER :: ji, jj, jk ! dummy loop indices 28 !!$ 29 !!$ INTEGER :: & ! ... boundary space indices 30 !!$ nib = 1, & ! nib = boundary point 31 !!$ nibm = 2, & ! nibm = 1st interior point 32 !!$ nibm2 = 3, & ! nibm2 = 2nd interior point 33 !!$ ! ... boundary time indices 34 !!$ nit = 1, & ! nit = now 35 !!$ nitm = 2, & ! nitm = before 36 !!$ nitm2 = 3 ! nitm2 = before-before 37 !!$ 38 !!$ !! * Substitutions 39 !!$# include "obc_vectopt_loop_substitute.h90" 40 !!$ !!--------------------------------------------------------------------------------- 41 !!$ !! NEMO/OPA 3.3 , NEMO Consortium (2010) 42 !!$ !! $Id$ 43 !!$ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 44 !!$ !!--------------------------------------------------------------------------------- 45 !!$ 46 !!$CONTAINS 47 !!$ 48 !!$ SUBROUTINE obc_rad ( kt ) 49 !!$ !!------------------------------------------------------------------------------ 50 !!$ !! SUBROUTINE obc_rad 51 !!$ !! ******************** 52 !!$ !! ** Purpose : 53 !!$ !! Perform swap of arrays to calculate radiative phase speeds at the open 54 !!$ !! boundaries and calculate those phase speeds if the open boundaries are 55 !!$ !! not fixed. In case of fixed open boundaries does nothing. 56 !!$ !! 57 !!$ !! The logical variable lp_obc_east, and/or lp_obc_west, and/or lp_obc_north, 58 !!$ !! and/or lp_obc_south allow the user to determine which boundary is an 59 !!$ !! open one (must be done in the param_obc.h90 file). 60 !!$ !! 61 !!$ !! ** Reference : 62 !!$ !! Marchesiello P., 1995, these de l'universite J. Fourier, Grenoble, France. 63 !!$ !! 64 !!$ !! History : 65 !!$ !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 from the 66 !!$ !! J. Molines and G. Madec version 67 !!$ !!------------------------------------------------------------------------------ 68 !!$ INTEGER, INTENT( in ) :: kt 69 !!$ !!---------------------------------------------------------------------- 70 !!$ 71 !!$ IF( lp_obc_east .AND. .NOT.lfbceast ) CALL obc_rad_east ( kt ) ! East open boundary 72 !!$ 73 !!$ IF( lp_obc_west .AND. .NOT.lfbcwest ) CALL obc_rad_west ( kt ) ! West open boundary 74 !!$ 75 !!$ IF( lp_obc_north .AND. .NOT.lfbcnorth ) CALL obc_rad_north( kt ) ! North open boundary 76 !!$ 77 !!$ IF( lp_obc_south .AND. .NOT.lfbcsouth ) CALL obc_rad_south( kt ) ! South open boundary 78 !!$ 79 !!$ END SUBROUTINE obc_rad 80 !!$ 81 !!$ 82 !!$ SUBROUTINE obc_rad_east ( kt ) 83 !!$ !!------------------------------------------------------------------------------ 84 !!$ !! *** SUBROUTINE obc_rad_east *** 85 !!$ !! 86 !!$ !! ** Purpose : 87 !!$ !! Perform swap of arrays to calculate radiative phase speeds at the open 88 !!$ !! east boundary and calculate those phase speeds if this OBC is not fixed. 89 !!$ !! In case of fixed OBC, this subrountine is not called. 90 !!$ !! 91 !!$ !! History : 92 !!$ !! ! 95-03 (J.-M. Molines) Original from SPEM 93 !!$ !! ! 97-07 (G. Madec, J.-M. Molines) additions 94 !!$ !! ! 97-12 (M. Imbard) Mpp adaptation 95 !!$ !! ! 00-06 (J.-M. Molines) 96 !!$ !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 97 !!$ !!------------------------------------------------------------------------------ 98 !!$ !! * Arguments 99 !!$ INTEGER, INTENT( in ) :: kt 100 !!$ 101 !!$ !! * Local declarations 102 !!$ INTEGER :: ij 103 !!$ REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy 104 !!$ REAL(wp) :: zucb, zucbm, zucbm2 105 !!$ !!------------------------------------------------------------------------------ 106 !!$ 107 !!$ ! 1. Swap arrays before calculating radiative velocities 108 !!$ ! ------------------------------------------------------ 109 !!$ 110 !!$ ! 1.1 zonal velocity 111 !!$ ! ------------------- 112 !!$ 113 !!$ IF( kt > nit000 .OR. ln_rstart ) THEN 114 !!$ 115 !!$ ! ... advance in time (time filter, array swap) 116 !!$ DO jk = 1, jpkm1 117 !!$ DO jj = 1, jpj 118 !!$ uebnd(jj,jk,nib ,nitm2) = uebnd(jj,jk,nib ,nitm)*uemsk(jj,jk) 119 !!$ uebnd(jj,jk,nibm ,nitm2) = uebnd(jj,jk,nibm ,nitm)*uemsk(jj,jk) 120 !!$ uebnd(jj,jk,nibm2,nitm2) = uebnd(jj,jk,nibm2,nitm)*uemsk(jj,jk) 121 !!$ END DO 122 !!$ END DO 123 !!$ ! ... fields nitm <== nit plus time filter at the boundary 124 !!$ DO ji = fs_nie0, fs_nie1 ! Vector opt. 125 !!$ DO jk = 1, jpkm1 126 !!$ DO jj = 1, jpj 127 !!$ uebnd(jj,jk,nib ,nitm) = uebnd(jj,jk,nib, nit)*uemsk(jj,jk) 128 !!$ uebnd(jj,jk,nibm ,nitm) = uebnd(jj,jk,nibm ,nit)*uemsk(jj,jk) 129 !!$ uebnd(jj,jk,nibm2,nitm) = uebnd(jj,jk,nibm2,nit)*uemsk(jj,jk) 130 !!$ ! ... fields nit <== now (kt+1) 131 !!$ ! ... Total or baroclinic velocity at b, bm and bm2 132 !!$ zucb = un(ji,jj,jk) 133 !!$ zucbm = un(ji-1,jj,jk) 134 !!$ zucbm2 = un(ji-2,jj,jk) 135 !!$ uebnd(jj,jk,nib ,nit) = zucb *uemsk(jj,jk) 136 !!$ uebnd(jj,jk,nibm ,nit) = zucbm *uemsk(jj,jk) 137 !!$ uebnd(jj,jk,nibm2,nit) = zucbm2 *uemsk(jj,jk) 138 !!$ END DO 139 !!$ END DO 140 !!$ END DO 141 !!$ IF( lk_mpp ) CALL mppobc(uebnd,jpjed,jpjef,jpieob,jpk*3*3,2,jpj, numout ) 142 !!$ 143 !!$ ! ... extremeties nie0, nie1 144 !!$ ij = jpjed +1 - njmpp 145 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 146 !!$ DO jk = 1,jpkm1 147 !!$ uebnd(ij,jk,nibm,nitm) = uebnd(ij+1 ,jk,nibm,nitm) 148 !!$ END DO 149 !!$ END IF 150 !!$ ij = jpjef +1 - njmpp 151 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 152 !!$ DO jk = 1,jpkm1 153 !!$ uebnd(ij,jk,nibm,nitm) = uebnd(ij-1 ,jk,nibm,nitm) 154 !!$ END DO 155 !!$ END IF 156 !!$ 157 !!$ ! 1.2 tangential velocity 158 !!$ ! ----------------------- 159 !!$ 160 !!$ ! ... advance in time (time filter, array swap) 161 !!$ DO jk = 1, jpkm1 162 !!$ DO jj = 1, jpj 163 !!$ ! ... fields nitm2 <== nitm 164 !!$ vebnd(jj,jk,nib ,nitm2) = vebnd(jj,jk,nib ,nitm)*vemsk(jj,jk) 165 !!$ vebnd(jj,jk,nibm ,nitm2) = vebnd(jj,jk,nibm ,nitm)*vemsk(jj,jk) 166 !!$ vebnd(jj,jk,nibm2,nitm2) = vebnd(jj,jk,nibm2,nitm)*vemsk(jj,jk) 167 !!$ END DO 168 !!$ END DO 169 !!$ 170 !!$ DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 171 !!$ DO jk = 1, jpkm1 172 !!$ DO jj = 1, jpj 173 !!$ vebnd(jj,jk,nib ,nitm) = vebnd(jj,jk,nib, nit)*vemsk(jj,jk) 174 !!$ vebnd(jj,jk,nibm ,nitm) = vebnd(jj,jk,nibm ,nit)*vemsk(jj,jk) 175 !!$ vebnd(jj,jk,nibm2,nitm) = vebnd(jj,jk,nibm2,nit)*vemsk(jj,jk) 176 !!$ ! ... fields nit <== now (kt+1) 177 !!$ vebnd(jj,jk,nib ,nit) = vn(ji ,jj,jk)*vemsk(jj,jk) 178 !!$ vebnd(jj,jk,nibm ,nit) = vn(ji-1,jj,jk)*vemsk(jj,jk) 179 !!$ vebnd(jj,jk,nibm2,nit) = vn(ji-2,jj,jk)*vemsk(jj,jk) 180 !!$ END DO 181 !!$ END DO 182 !!$ END DO 183 !!$ IF( lk_mpp ) CALL mppobc(vebnd,jpjed,jpjef,jpieob+1,jpk*3*3,2,jpj, numout ) 184 !!$ 185 !!$ !... extremeties nie0, nie1 186 !!$ ij = jpjed +1 - njmpp 187 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 188 !!$ DO jk = 1,jpkm1 189 !!$ vebnd(ij,jk,nibm,nitm) = vebnd(ij+1 ,jk,nibm,nitm) 190 !!$ END DO 191 !!$ END IF 192 !!$ ij = jpjef +1 - njmpp 193 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 194 !!$ DO jk = 1,jpkm1 195 !!$ vebnd(ij,jk,nibm,nitm) = vebnd(ij-1 ,jk,nibm,nitm) 196 !!$ END DO 197 !!$ END IF 198 !!$ 199 !!$ ! 1.3 Temperature and salinity 200 !!$ ! ---------------------------- 201 !!$ 202 !!$ ! ... advance in time (time filter, array swap) 203 !!$ DO jk = 1, jpkm1 204 !!$ DO jj = 1, jpj 205 !!$ ! ... fields nitm <== nit plus time filter at the boundary 206 !!$ tebnd(jj,jk,nib,nitm) = tebnd(jj,jk,nib,nit)*temsk(jj,jk) 207 !!$ sebnd(jj,jk,nib,nitm) = sebnd(jj,jk,nib,nit)*temsk(jj,jk) 208 !!$ END DO 209 !!$ END DO 210 !!$ 211 !!$ DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 212 !!$ DO jk = 1, jpkm1 213 !!$ DO jj = 1, jpj 214 !!$ tebnd(jj,jk,nibm,nitm) = tebnd(jj,jk,nibm,nit)*temsk(jj,jk) 215 !!$ sebnd(jj,jk,nibm,nitm) = sebnd(jj,jk,nibm,nit)*temsk(jj,jk) 216 !!$ ! ... fields nit <== now (kt+1) 217 !!$ tebnd(jj,jk,nib ,nit) = tn(ji ,jj,jk)*temsk(jj,jk) 218 !!$ tebnd(jj,jk,nibm ,nit) = tn(ji-1,jj,jk)*temsk(jj,jk) 219 !!$ sebnd(jj,jk,nib ,nit) = sn(ji ,jj,jk)*temsk(jj,jk) 220 !!$ sebnd(jj,jk,nibm ,nit) = sn(ji-1,jj,jk)*temsk(jj,jk) 221 !!$ END DO 222 !!$ END DO 223 !!$ END DO 224 !!$ IF( lk_mpp ) CALL mppobc(tebnd,jpjed,jpjef,jpieob+1,jpk*2*2,2,jpj, numout ) 225 !!$ IF( lk_mpp ) CALL mppobc(sebnd,jpjed,jpjef,jpieob+1,jpk*2*2,2,jpj, numout ) 226 !!$ 227 !!$ ! ... extremeties nie0, nie1 228 !!$ ij = jpjed +1 - njmpp 229 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 230 !!$ DO jk = 1,jpkm1 231 !!$ tebnd(ij,jk,nibm,nitm) = tebnd(ij+1 ,jk,nibm,nitm) 232 !!$ sebnd(ij,jk,nibm,nitm) = sebnd(ij+1 ,jk,nibm,nitm) 233 !!$ END DO 234 !!$ END IF 235 !!$ ij = jpjef +1 - njmpp 236 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 237 !!$ DO jk = 1,jpkm1 238 !!$ tebnd(ij,jk,nibm,nitm) = tebnd(ij-1 ,jk,nibm,nitm) 239 !!$ sebnd(ij,jk,nibm,nitm) = sebnd(ij-1 ,jk,nibm,nitm) 240 !!$ END DO 241 !!$ END IF 242 !!$ 243 !!$ END IF ! End of array swap 244 !!$ 245 !!$ ! 2 - Calculation of radiation velocities 246 !!$ ! --------------------------------------- 247 !!$ 248 !!$ IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 249 !!$ 250 !!$ ! 2.1 Calculate the normal velocity U based on phase velocity u_cxebnd 251 !!$ ! --------------------------------------------------------------------- 252 !!$ ! 253 !!$ ! nibm2 nibm nib 254 !!$ ! | nibm | nib |/// 255 !!$ ! | | | | |/// 256 !!$ ! jj-line --f----v----f----v----f--- 257 !!$ ! | | | | |/// 258 !!$ ! | | |/// 259 !!$ ! jj-line u T u T u/// 260 !!$ ! | | |/// 261 !!$ ! | | | | |/// 262 !!$ ! jpieob-2 jpieob-1 jpieob 263 !!$ ! | | 264 !!$ ! jpieob-1 jpieob 265 !!$ ! 266 !!$ ! ... (jpjedp1, jpjefm1),jpieob 267 !!$ DO ji = fs_nie0, fs_nie1 ! Vector opt. 268 !!$ DO jk = 1, jpkm1 269 !!$ DO jj = 2, jpjm1 270 !!$ ! ... 2* gradi(u) (T-point i=nibm, time mean) 271 !!$ z2dx = ( uebnd(jj,jk,nibm ,nit) + uebnd(jj,jk,nibm ,nitm2) & 272 !!$ - 2.*uebnd(jj,jk,nibm2,nitm) ) / e1t(ji-1,jj) 273 !!$ ! ... 2* gradj(u) (u-point i=nibm, time nitm) 274 !!$ z2dy = ( uebnd(jj+1,jk,nibm,nitm) - uebnd(jj-1,jk,nibm,nitm) ) / e2u(ji-1,jj) 275 !!$ ! ... square of the norm of grad(u) 276 !!$ z4nor2 = z2dx * z2dx + z2dy * z2dy 277 !!$ ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 278 !!$ zdt = uebnd(jj,jk,nibm,nitm2) - uebnd(jj,jk,nibm,nit) 279 !!$ ! ... i-phase speed ratio (bounded by 1) 280 !!$ IF( z4nor2 == 0. ) THEN 281 !!$ z4nor2=.00001 282 !!$ END IF 283 !!$ z05cx = zdt * z2dx / z4nor2 284 !!$ u_cxebnd(jj,jk) = z05cx*uemsk(jj,jk) 285 !!$ END DO 286 !!$ END DO 287 !!$ END DO 288 !!$ 289 !!$ ! 2.2 Calculate the tangential velocity based on phase velocity v_cxebnd 290 !!$ ! ----------------------------------------------------------------------- 291 !!$ ! 292 !!$ ! nibm2 nibm nib 293 !!$ ! | nibm | nib///|/// 294 !!$ ! | | | |////|/// 295 !!$ ! jj-line --v----f----v----f----v--- 296 !!$ ! | | | |////|/// 297 !!$ ! | | | |////|/// 298 !!$ ! | jpieob-1| jpieob /|/// 299 !!$ ! | | | 300 !!$ ! jpieob-1 jpieob jpieob+1 301 !!$ ! 302 !!$ ! ... (jpjedp1, jpjefm1), jpieob+1 303 !!$ DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 304 !!$ DO jk = 1, jpkm1 305 !!$ DO jj = 2, jpjm1 306 !!$ ! ... 2* i-gradient of v (f-point i=nibm, time mean) 307 !!$ z2dx = ( vebnd(jj,jk,nibm ,nit) + vebnd(jj,jk,nibm ,nitm2) & 308 !!$ - 2.*vebnd(jj,jk,nibm2,nitm) ) / e1f(ji-2,jj) 309 !!$ ! ... 2* j-gradient of v (v-point i=nibm, time nitm) 310 !!$ z2dy = ( vebnd(jj+1,jk,nibm,nitm) - vebnd(jj-1,jk,nibm,nitm) ) / e2v(ji-1,jj) 311 !!$ ! ... square of the norm of grad(v) 312 !!$ z4nor2 = z2dx * z2dx + z2dy * z2dy 313 !!$ ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 314 !!$ zdt = vebnd(jj,jk,nibm,nitm2) - vebnd(jj,jk,nibm,nit) 315 !!$ ! ... i-phase speed ratio (bounded by 1) and save the unbounded phase 316 !!$ ! velocity ratio no divided by e1f for the tracer radiation 317 !!$ IF( z4nor2 == 0. ) THEN 318 !!$ z4nor2=.000001 319 !!$ END IF 320 !!$ z05cx = zdt * z2dx / z4nor2 321 !!$ v_cxebnd(jj,jk) = z05cx*vemsk(jj,jk) 322 !!$ END DO 323 !!$ END DO 324 !!$ END DO 325 !!$ IF( lk_mpp ) CALL mppobc(v_cxebnd,jpjed,jpjef,jpieob+1,jpk,2,jpj, numout ) 326 !!$ 327 !!$ ! ... extremeties nie0, nie1 328 !!$ ij = jpjed +1 - njmpp 329 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 330 !!$ DO jk = 1,jpkm1 331 !!$ v_cxebnd(ij,jk) = v_cxebnd(ij+1 ,jk) 332 !!$ END DO 333 !!$ END IF 334 !!$ ij = jpjef +1 - njmpp 335 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 336 !!$ DO jk = 1,jpkm1 337 !!$ v_cxebnd(ij,jk) = v_cxebnd(ij-1 ,jk) 338 !!$ END DO 339 !!$ END IF 340 !!$ 341 !!$ END IF 342 !!$ 343 !!$ END SUBROUTINE obc_rad_east 344 !!$ 345 !!$ 346 !!$ SUBROUTINE obc_rad_west ( kt ) 347 !!$ !!------------------------------------------------------------------------------ 348 !!$ !! *** SUBROUTINE obc_rad_west *** 349 !!$ !! 350 !!$ !! ** Purpose : 351 !!$ !! Perform swap of arrays to calculate radiative phase speeds at the open 352 !!$ !! west boundary and calculate those phase speeds if this OBC is not fixed. 353 !!$ !! In case of fixed OBC, this subrountine is not called. 354 !!$ !! 355 !!$ !! History : 356 !!$ !! ! 95-03 (J.-M. Molines) Original from SPEM 357 !!$ !! ! 97-07 (G. Madec, J.-M. Molines) additions 358 !!$ !! ! 97-12 (M. Imbard) Mpp adaptation 359 !!$ !! ! 00-06 (J.-M. Molines) 360 !!$ !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 361 !!$ !!------------------------------------------------------------------------------ 362 !!$ !! * Arguments 363 !!$ INTEGER, INTENT( in ) :: kt 364 !!$ 365 !!$ !! * Local declarations 366 !!$ INTEGER :: ij 367 !!$ REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy 368 !!$ REAL(wp) :: zucb, zucbm, zucbm2 369 !!$ !!------------------------------------------------------------------------------ 370 !!$ 371 !!$ ! 1. Swap arrays before calculating radiative velocities 372 !!$ ! ------------------------------------------------------ 373 !!$ 374 !!$ ! 1.1 zonal velocity 375 !!$ ! ------------------- 376 !!$ 377 !!$ IF( kt > nit000 .OR. ln_rstart ) THEN 378 !!$ 379 !!$ ! ... advance in time (time filter, array swap) 380 !!$ DO jk = 1, jpkm1 381 !!$ DO jj = 1, jpj 382 !!$ uwbnd(jj,jk,nib ,nitm2) = uwbnd(jj,jk,nib ,nitm)*uwmsk(jj,jk) 383 !!$ uwbnd(jj,jk,nibm ,nitm2) = uwbnd(jj,jk,nibm ,nitm)*uwmsk(jj,jk) 384 !!$ uwbnd(jj,jk,nibm2,nitm2) = uwbnd(jj,jk,nibm2,nitm)*uwmsk(jj,jk) 385 !!$ END DO 386 !!$ END DO 387 !!$ 388 !!$ ! ... fields nitm <== nit plus time filter at the boundary 389 !!$ DO ji = fs_niw0, fs_niw1 ! Vector opt. 390 !!$ DO jk = 1, jpkm1 391 !!$ DO jj = 1, jpj 392 !!$ uwbnd(jj,jk,nib ,nitm) = uwbnd(jj,jk,nib ,nit)*uwmsk(jj,jk) 393 !!$ uwbnd(jj,jk,nibm ,nitm) = uwbnd(jj,jk,nibm ,nit)*uwmsk(jj,jk) 394 !!$ uwbnd(jj,jk,nibm2,nitm) = uwbnd(jj,jk,nibm2,nit)*uwmsk(jj,jk) 395 !!$ ! ... total or baroclinic velocity at b, bm and bm2 396 !!$ zucb = un (ji,jj,jk) 397 !!$ zucbm = un (ji+1,jj,jk) 398 !!$ zucbm2 = un (ji+2,jj,jk) 399 !!$ 400 !!$ ! ... fields nit <== now (kt+1) 401 !!$ uwbnd(jj,jk,nib ,nit) = zucb *uwmsk(jj,jk) 402 !!$ uwbnd(jj,jk,nibm ,nit) = zucbm *uwmsk(jj,jk) 403 !!$ uwbnd(jj,jk,nibm2,nit) = zucbm2*uwmsk(jj,jk) 404 !!$ END DO 405 !!$ END DO 406 !!$ END DO 407 !!$ IF( lk_mpp ) CALL mppobc(uwbnd,jpjwd,jpjwf,jpiwob,jpk*3*3,2,jpj, numout ) 408 !!$ 409 !!$ ! ... extremeties niw0, niw1 410 !!$ ij = jpjwd +1 - njmpp 411 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 412 !!$ DO jk = 1,jpkm1 413 !!$ uwbnd(ij,jk,nibm,nitm) = uwbnd(ij+1 ,jk,nibm,nitm) 414 !!$ END DO 415 !!$ END IF 416 !!$ ij = jpjwf +1 - njmpp 417 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 418 !!$ DO jk = 1,jpkm1 419 !!$ uwbnd(ij,jk,nibm,nitm) = uwbnd(ij-1 ,jk,nibm,nitm) 420 !!$ END DO 421 !!$ END IF 422 !!$ 423 !!$ ! 1.2 tangential velocity 424 !!$ ! ----------------------- 425 !!$ 426 !!$ ! ... advance in time (time filter, array swap) 427 !!$ DO jk = 1, jpkm1 428 !!$ DO jj = 1, jpj 429 !!$ ! ... fields nitm2 <== nitm 430 !!$ vwbnd(jj,jk,nib ,nitm2) = vwbnd(jj,jk,nib ,nitm)*vwmsk(jj,jk) 431 !!$ vwbnd(jj,jk,nibm ,nitm2) = vwbnd(jj,jk,nibm ,nitm)*vwmsk(jj,jk) 432 !!$ vwbnd(jj,jk,nibm2,nitm2) = vwbnd(jj,jk,nibm2,nitm)*vwmsk(jj,jk) 433 !!$ END DO 434 !!$ END DO 435 !!$ 436 !!$ DO ji = fs_niw0, fs_niw1 ! Vector opt. 437 !!$ DO jk = 1, jpkm1 438 !!$ DO jj = 1, jpj 439 !!$ vwbnd(jj,jk,nib ,nitm) = vwbnd(jj,jk,nib, nit)*vwmsk(jj,jk) 440 !!$ vwbnd(jj,jk,nibm ,nitm) = vwbnd(jj,jk,nibm ,nit)*vwmsk(jj,jk) 441 !!$ vwbnd(jj,jk,nibm2,nitm) = vwbnd(jj,jk,nibm2,nit)*vwmsk(jj,jk) 442 !!$ ! ... fields nit <== now (kt+1) 443 !!$ vwbnd(jj,jk,nib ,nit) = vn(ji ,jj,jk)*vwmsk(jj,jk) 444 !!$ vwbnd(jj,jk,nibm ,nit) = vn(ji+1,jj,jk)*vwmsk(jj,jk) 445 !!$ vwbnd(jj,jk,nibm2,nit) = vn(ji+2,jj,jk)*vwmsk(jj,jk) 446 !!$ END DO 447 !!$ END DO 448 !!$ END DO 449 !!$ IF( lk_mpp ) CALL mppobc(vwbnd,jpjwd,jpjwf,jpiwob,jpk*3*3,2,jpj, numout ) 450 !!$ 451 !!$ ! ... extremeties niw0, niw1 452 !!$ ij = jpjwd +1 - njmpp 453 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 454 !!$ DO jk = 1,jpkm1 455 !!$ vwbnd(ij,jk,nibm,nitm) = vwbnd(ij+1 ,jk,nibm,nitm) 456 !!$ END DO 457 !!$ END IF 458 !!$ ij = jpjwf +1 - njmpp 459 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 460 !!$ DO jk = 1,jpkm1 461 !!$ vwbnd(ij,jk,nibm,nitm) = vwbnd(ij-1 ,jk,nibm,nitm) 462 !!$ END DO 463 !!$ END IF 464 !!$ 465 !!$ ! 1.3 Temperature and salinity 466 !!$ ! ---------------------------- 467 !!$ 468 !!$ ! ... advance in time (time filter, array swap) 469 !!$ DO jk = 1, jpkm1 470 !!$ DO jj = 1, jpj 471 !!$ ! ... fields nitm <== nit plus time filter at the boundary 472 !!$ twbnd(jj,jk,nib,nitm) = twbnd(jj,jk,nib,nit)*twmsk(jj,jk) 473 !!$ swbnd(jj,jk,nib,nitm) = swbnd(jj,jk,nib,nit)*twmsk(jj,jk) 474 !!$ END DO 475 !!$ END DO 476 !!$ 477 !!$ DO ji = fs_niw0, fs_niw1 ! Vector opt. 478 !!$ DO jk = 1, jpkm1 479 !!$ DO jj = 1, jpj 480 !!$ twbnd(jj,jk,nibm ,nitm) = twbnd(jj,jk,nibm ,nit)*twmsk(jj,jk) 481 !!$ swbnd(jj,jk,nibm ,nitm) = swbnd(jj,jk,nibm ,nit)*twmsk(jj,jk) 482 !!$ ! ... fields nit <== now (kt+1) 483 !!$ twbnd(jj,jk,nib ,nit) = tn(ji ,jj,jk)*twmsk(jj,jk) 484 !!$ twbnd(jj,jk,nibm ,nit) = tn(ji+1 ,jj,jk)*twmsk(jj,jk) 485 !!$ swbnd(jj,jk,nib ,nit) = sn(ji ,jj,jk)*twmsk(jj,jk) 486 !!$ swbnd(jj,jk,nibm ,nit) = sn(ji+1 ,jj,jk)*twmsk(jj,jk) 487 !!$ END DO 488 !!$ END DO 489 !!$ END DO 490 !!$ IF( lk_mpp ) CALL mppobc(twbnd,jpjwd,jpjwf,jpiwob,jpk*2*2,2,jpj, numout ) 491 !!$ IF( lk_mpp ) CALL mppobc(swbnd,jpjwd,jpjwf,jpiwob,jpk*2*2,2,jpj, numout ) 492 !!$ 493 !!$ ! ... extremeties niw0, niw1 494 !!$ ij = jpjwd +1 - njmpp 495 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 496 !!$ DO jk = 1,jpkm1 497 !!$ twbnd(ij,jk,nibm,nitm) = twbnd(ij+1 ,jk,nibm,nitm) 498 !!$ swbnd(ij,jk,nibm,nitm) = swbnd(ij+1 ,jk,nibm,nitm) 499 !!$ END DO 500 !!$ END IF 501 !!$ ij = jpjwf +1 - njmpp 502 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 503 !!$ DO jk = 1,jpkm1 504 !!$ twbnd(ij,jk,nibm,nitm) = twbnd(ij-1 ,jk,nibm,nitm) 505 !!$ swbnd(ij,jk,nibm,nitm) = swbnd(ij-1 ,jk,nibm,nitm) 506 !!$ END DO 507 !!$ END IF 508 !!$ 509 !!$ END IF ! End of array swap 510 !!$ 511 !!$ ! 2 - Calculation of radiation velocities 512 !!$ ! --------------------------------------- 513 !!$ 514 !!$ IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 515 !!$ 516 !!$ ! 2.1 Calculate the normal velocity U based on phase velocity u_cxwbnd 517 !!$ ! ---------------------------------------------------------------------- 518 !!$ ! 519 !!$ ! nib nibm nibm2 520 !!$ ! ///| nib | nibm | 521 !!$ ! ///| | | | | 522 !!$ ! ---f----v----f----v----f-- jj-line 523 !!$ ! ///| | | | | 524 !!$ ! ///| | | 525 !!$ ! ///u T u T u jj-line 526 !!$ ! ///| | | 527 !!$ ! ///| | | | | 528 !!$ ! jpiwob jpiwob+1 jpiwob+2 529 !!$ ! | | 530 !!$ ! jpiwob+1 jpiwob+2 531 !!$ ! 532 !!$ ! ... If free surface formulation: 533 !!$ ! ... radiative conditions on the total part + relaxation toward climatology 534 !!$ ! ... (jpjwdp1, jpjwfm1), jpiwob 535 !!$ DO ji = fs_niw0, fs_niw1 ! Vector opt. 536 !!$ DO jk = 1, jpkm1 537 !!$ DO jj = 2, jpjm1 538 !!$ ! ... 2* gradi(u) (T-point i=nibm, time mean) 539 !!$ z2dx = ( - uwbnd(jj,jk,nibm ,nit) - uwbnd(jj,jk,nibm ,nitm2) & 540 !!$ + 2.*uwbnd(jj,jk,nibm2,nitm) ) / e1t(ji+2,jj) 541 !!$ ! ... 2* gradj(u) (u-point i=nibm, time nitm) 542 !!$ z2dy = ( uwbnd(jj+1,jk,nibm,nitm) - uwbnd(jj-1,jk,nibm,nitm) ) / e2u(ji+1,jj) 543 !!$ ! ... square of the norm of grad(u) 544 !!$ z4nor2 = z2dx * z2dx + z2dy * z2dy 545 !!$ ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 546 !!$ zdt = uwbnd(jj,jk,nibm,nitm2) - uwbnd(jj,jk,nibm,nit) 547 !!$ ! ... i-phase speed ratio (bounded by -1) 548 !!$ IF( z4nor2 == 0. ) THEN 549 !!$ z4nor2=0.00001 550 !!$ END IF 551 !!$ z05cx = zdt * z2dx / z4nor2 552 !!$ u_cxwbnd(jj,jk)=z05cx*uwmsk(jj,jk) 553 !!$ END DO 554 !!$ END DO 555 !!$ END DO 556 !!$ 557 !!$ ! 2.2 Calculate the tangential velocity based on phase velocity v_cxwbnd 558 !!$ ! ----------------------------------------------------------------------- 559 !!$ ! 560 !!$ ! nib nibm nibm2 561 !!$ ! ///|///nib | nibm | nibm2 562 !!$ ! ///|////| | | | | | 563 !!$ ! ---v----f----v----f----v----f----v-- jj-line 564 !!$ ! ///|////| | | | | | 565 !!$ ! ///|////| | | | | | 566 !!$ ! jpiwob jpiwob+1 jpiwob+2 567 !!$ ! | | | 568 !!$ ! jpiwob jpiwob+1 jpiwob+2 569 !!$ ! 570 !!$ ! ... radiative condition plus Raymond-Kuo 571 !!$ ! ... (jpjwdp1, jpjwfm1),jpiwob 572 !!$ DO ji = fs_niw0, fs_niw1 ! Vector opt. 573 !!$ DO jk = 1, jpkm1 574 !!$ DO jj = 2, jpjm1 575 !!$ ! ... 2* i-gradient of v (f-point i=nibm, time mean) 576 !!$ z2dx = ( - vwbnd(jj,jk,nibm ,nit) - vwbnd(jj,jk,nibm ,nitm2) & 577 !!$ + 2.*vwbnd(jj,jk,nibm2,nitm) ) / e1f(ji+1,jj) 578 !!$ ! ... 2* j-gradient of v (v-point i=nibm, time nitm) 579 !!$ z2dy = ( vwbnd(jj+1,jk,nibm,nitm) - vwbnd(jj-1,jk,nibm,nitm) ) / e2v(ji+1,jj) 580 !!$ ! ... square of the norm of grad(v) 581 !!$ z4nor2 = z2dx * z2dx + z2dy * z2dy 582 !!$ ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 583 !!$ zdt = vwbnd(jj,jk,nibm,nitm2) - vwbnd(jj,jk,nibm,nit) 584 !!$ ! ... i-phase speed ratio (bounded by -1) and save the unbounded phase 585 !!$ ! velocity ratio no divided by e1f for the tracer radiation 586 !!$ IF( z4nor2 == 0) THEN 587 !!$ z4nor2=0.000001 588 !!$ endif 589 !!$ z05cx = zdt * z2dx / z4nor2 590 !!$ v_cxwbnd(jj,jk) = z05cx*vwmsk(jj,jk) 591 !!$ END DO 592 !!$ END DO 593 !!$ END DO 594 !!$ IF( lk_mpp ) CALL mppobc(v_cxwbnd,jpjwd,jpjwf,jpiwob,jpk,2,jpj, numout ) 595 !!$ 596 !!$ ! ... extremeties niw0, niw1 597 !!$ ij = jpjwd +1 - njmpp 598 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 599 !!$ DO jk = 1,jpkm1 600 !!$ v_cxwbnd(ij,jk) = v_cxwbnd(ij+1 ,jk) 601 !!$ END DO 602 !!$ END IF 603 !!$ ij = jpjwf +1 - njmpp 604 !!$ IF( ij >= 2 .AND. ij < jpjm1 ) THEN 605 !!$ DO jk = 1,jpkm1 606 !!$ v_cxwbnd(ij,jk) = v_cxwbnd(ij-1 ,jk) 607 !!$ END DO 608 !!$ END IF 609 !!$ 610 !!$ END IF 611 !!$ 612 !!$ END SUBROUTINE obc_rad_west 613 !!$ 614 !!$ 615 !!$ SUBROUTINE obc_rad_north ( kt ) 616 !!$ !!------------------------------------------------------------------------------ 617 !!$ !! *** SUBROUTINE obc_rad_north *** 618 !!$ !! 619 !!$ !! ** Purpose : 620 !!$ !! Perform swap of arrays to calculate radiative phase speeds at the open 621 !!$ !! north boundary and calculate those phase speeds if this OBC is not fixed. 622 !!$ !! In case of fixed OBC, this subrountine is not called. 623 !!$ !! 624 !!$ !! History : 625 !!$ !! ! 95-03 (J.-M. Molines) Original from SPEM 626 !!$ !! ! 97-07 (G. Madec, J.-M. Molines) additions 627 !!$ !! ! 97-12 (M. Imbard) Mpp adaptation 628 !!$ !! ! 00-06 (J.-M. Molines) 629 !!$ !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 630 !!$ !!------------------------------------------------------------------------------ 631 !!$ !! * Arguments 632 !!$ INTEGER, INTENT( in ) :: kt 633 !!$ 634 !!$ !! * Local declarations 635 !!$ INTEGER :: ii 636 !!$ REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy 637 !!$ REAL(wp) :: zvcb, zvcbm, zvcbm2 638 !!$ !!------------------------------------------------------------------------------ 639 !!$ 640 !!$ ! 1. Swap arrays before calculating radiative velocities 641 !!$ ! ------------------------------------------------------ 642 !!$ 643 !!$ ! 1.1 zonal velocity 644 !!$ ! ------------------- 645 !!$ 646 !!$ IF( kt > nit000 .OR. ln_rstart ) THEN 647 !!$ 648 !!$ ! ... advance in time (time filter, array swap) 649 !!$ DO jk = 1, jpkm1 650 !!$ DO ji = 1, jpi 651 !!$ ! ... fields nitm2 <== nitm 652 !!$ unbnd(ji,jk,nib ,nitm2) = unbnd(ji,jk,nib ,nitm)*unmsk(ji,jk) 653 !!$ unbnd(ji,jk,nibm ,nitm2) = unbnd(ji,jk,nibm ,nitm)*unmsk(ji,jk) 654 !!$ unbnd(ji,jk,nibm2,nitm2) = unbnd(ji,jk,nibm2,nitm)*unmsk(ji,jk) 655 !!$ END DO 656 !!$ END DO 657 !!$ 658 !!$ DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt. 659 !!$ DO jk = 1, jpkm1 660 !!$ DO ji = 1, jpi 661 !!$ unbnd(ji,jk,nib ,nitm) = unbnd(ji,jk,nib, nit)*unmsk(ji,jk) 662 !!$ unbnd(ji,jk,nibm ,nitm) = unbnd(ji,jk,nibm ,nit)*unmsk(ji,jk) 663 !!$ unbnd(ji,jk,nibm2,nitm) = unbnd(ji,jk,nibm2,nit)*unmsk(ji,jk) 664 !!$ ! ... fields nit <== now (kt+1) 665 !!$ unbnd(ji,jk,nib ,nit) = un(ji,jj, jk)*unmsk(ji,jk) 666 !!$ unbnd(ji,jk,nibm ,nit) = un(ji,jj-1,jk)*unmsk(ji,jk) 667 !!$ unbnd(ji,jk,nibm2,nit) = un(ji,jj-2,jk)*unmsk(ji,jk) 668 !!$ END DO 669 !!$ END DO 670 !!$ END DO 671 !!$ IF( lk_mpp ) CALL mppobc(unbnd,jpind,jpinf,jpjnob+1,jpk*3*3,1,jpi, numout ) 672 !!$ 673 !!$ ! ... extremeties njn0,njn1 674 !!$ ii = jpind + 1 - nimpp 675 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 676 !!$ DO jk = 1, jpkm1 677 !!$ unbnd(ii,jk,nibm,nitm) = unbnd(ii+1,jk,nibm,nitm) 678 !!$ END DO 679 !!$ END IF 680 !!$ ii = jpinf + 1 - nimpp 681 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 682 !!$ DO jk = 1, jpkm1 683 !!$ unbnd(ii,jk,nibm,nitm) = unbnd(ii-1,jk,nibm,nitm) 684 !!$ END DO 685 !!$ END IF 686 !!$ 687 !!$ ! 1.2. normal velocity 688 !!$ ! -------------------- 689 !!$ 690 !!$ ! ... advance in time (time filter, array swap) 691 !!$ DO jk = 1, jpkm1 692 !!$ DO ji = 1, jpi 693 !!$ ! ... fields nitm2 <== nitm 694 !!$ vnbnd(ji,jk,nib ,nitm2) = vnbnd(ji,jk,nib ,nitm)*vnmsk(ji,jk) 695 !!$ vnbnd(ji,jk,nibm ,nitm2) = vnbnd(ji,jk,nibm ,nitm)*vnmsk(ji,jk) 696 !!$ vnbnd(ji,jk,nibm2,nitm2) = vnbnd(ji,jk,nibm2,nitm)*vnmsk(ji,jk) 697 !!$ END DO 698 !!$ END DO 699 !!$ 700 !!$ DO jj = fs_njn0, fs_njn1 ! Vector opt. 701 !!$ DO jk = 1, jpkm1 702 !!$ DO ji = 1, jpi 703 !!$ vnbnd(ji,jk,nib ,nitm) = vnbnd(ji,jk,nib, nit)*vnmsk(ji,jk) 704 !!$ vnbnd(ji,jk,nibm ,nitm) = vnbnd(ji,jk,nibm ,nit)*vnmsk(ji,jk) 705 !!$ vnbnd(ji,jk,nibm2,nitm) = vnbnd(ji,jk,nibm2,nit)*vnmsk(ji,jk) 706 !!$ ! ... fields nit <== now (kt+1) 707 !!$ ! ... total or baroclinic velocity at b, bm and bm2 708 !!$ zvcb = vn (ji,jj,jk) 709 !!$ zvcbm = vn (ji,jj-1,jk) 710 !!$ zvcbm2 = vn (ji,jj-2,jk) 711 !!$ ! ... fields nit <== now (kt+1) 712 !!$ vnbnd(ji,jk,nib ,nit) = zvcb *vnmsk(ji,jk) 713 !!$ vnbnd(ji,jk,nibm ,nit) = zvcbm *vnmsk(ji,jk) 714 !!$ vnbnd(ji,jk,nibm2,nit) = zvcbm2*vnmsk(ji,jk) 715 !!$ END DO 716 !!$ END DO 717 !!$ END DO 718 !!$ IF( lk_mpp ) CALL mppobc(vnbnd,jpind,jpinf,jpjnob,jpk*3*3,1,jpi, numout ) 719 !!$ 720 !!$ ! ... extremeties njn0,njn1 721 !!$ ii = jpind + 1 - nimpp 722 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 723 !!$ DO jk = 1, jpkm1 724 !!$ vnbnd(ii,jk,nibm,nitm) = vnbnd(ii+1,jk,nibm,nitm) 725 !!$ END DO 726 !!$ END IF 727 !!$ ii = jpinf + 1 - nimpp 728 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 729 !!$ DO jk = 1, jpkm1 730 !!$ vnbnd(ii,jk,nibm,nitm) = vnbnd(ii-1,jk,nibm,nitm) 731 !!$ END DO 732 !!$ END IF 733 !!$ 734 !!$ ! 1.3 Temperature and salinity 735 !!$ ! ---------------------------- 736 !!$ 737 !!$ ! ... advance in time (time filter, array swap) 738 !!$ DO jk = 1, jpkm1 739 !!$ DO ji = 1, jpi 740 !!$ ! ... fields nitm <== nit plus time filter at the boundary 741 !!$ tnbnd(ji,jk,nib ,nitm) = tnbnd(ji,jk,nib,nit)*tnmsk(ji,jk) 742 !!$ snbnd(ji,jk,nib ,nitm) = snbnd(ji,jk,nib,nit)*tnmsk(ji,jk) 743 !!$ END DO 744 !!$ END DO 745 !!$ 746 !!$ DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt. 747 !!$ DO jk = 1, jpkm1 748 !!$ DO ji = 1, jpi 749 !!$ tnbnd(ji,jk,nibm ,nitm) = tnbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk) 750 !!$ snbnd(ji,jk,nibm ,nitm) = snbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk) 751 !!$ ! ... fields nit <== now (kt+1) 752 !!$ tnbnd(ji,jk,nib ,nit) = tn(ji,jj, jk)*tnmsk(ji,jk) 753 !!$ tnbnd(ji,jk,nibm ,nit) = tn(ji,jj-1,jk)*tnmsk(ji,jk) 754 !!$ snbnd(ji,jk,nib ,nit) = sn(ji,jj, jk)*tnmsk(ji,jk) 755 !!$ snbnd(ji,jk,nibm ,nit) = sn(ji,jj-1,jk)*tnmsk(ji,jk) 756 !!$ END DO 757 !!$ END DO 758 !!$ END DO 759 !!$ IF( lk_mpp ) CALL mppobc(tnbnd,jpind,jpinf,jpjnob+1,jpk*2*2,1,jpi, numout ) 760 !!$ IF( lk_mpp ) CALL mppobc(snbnd,jpind,jpinf,jpjnob+1,jpk*2*2,1,jpi, numout ) 761 !!$ 762 !!$ ! ... extremeties njn0,njn1 763 !!$ ii = jpind + 1 - nimpp 764 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 765 !!$ DO jk = 1, jpkm1 766 !!$ tnbnd(ii,jk,nibm,nitm) = tnbnd(ii+1,jk,nibm,nitm) 767 !!$ snbnd(ii,jk,nibm,nitm) = snbnd(ii+1,jk,nibm,nitm) 768 !!$ END DO 769 !!$ END IF 770 !!$ ii = jpinf + 1 - nimpp 771 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 772 !!$ DO jk = 1, jpkm1 773 !!$ tnbnd(ii,jk,nibm,nitm) = tnbnd(ii-1,jk,nibm,nitm) 774 !!$ snbnd(ii,jk,nibm,nitm) = snbnd(ii-1,jk,nibm,nitm) 775 !!$ END DO 776 !!$ END IF 777 !!$ 778 !!$ END IF ! End of array swap 779 !!$ 780 !!$ ! 2 - Calculation of radiation velocities 781 !!$ ! --------------------------------------- 782 !!$ 783 !!$ IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 784 !!$ 785 !!$ ! 2.1 Calculate the normal velocity based on phase velocity u_cynbnd 786 !!$ ! ------------------------------------------------------------------- 787 !!$ ! 788 !!$ ! ji-row 789 !!$ ! | 790 !!$ ! nib -///u////// jpjnob + 1 791 !!$ ! /////|////// 792 !!$ ! nib -----f----- jpjnob 793 !!$ ! | 794 !!$ ! nibm-- u ---- jpjnob 795 !!$ ! | 796 !!$ ! nibm -----f----- jpjnob-1 797 !!$ ! | 798 !!$ ! nibm2-- u ---- jpjnob-1 799 !!$ ! | 800 !!$ ! nibm2 -----f----- jpjnob-2 801 !!$ ! | 802 !!$ ! ... radiative condition 803 !!$ ! ... jpjnob+1,(jpindp1, jpinfm1) 804 !!$ DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt. 805 !!$ DO jk = 1, jpkm1 806 !!$ DO ji = 2, jpim1 807 !!$ ! ... 2* j-gradient of u (f-point i=nibm, time mean) 808 !!$ z2dx = ( unbnd(ji,jk,nibm ,nit) + unbnd(ji,jk,nibm ,nitm2) & 809 !!$ - 2.*unbnd(ji,jk,nibm2,nitm)) / e2f(ji,jj-2) 810 !!$ ! ... 2* i-gradient of u (u-point i=nibm, time nitm) 811 !!$ z2dy = ( unbnd(ji+1,jk,nibm,nitm) - unbnd(ji-1,jk,nibm,nitm) ) / e1u(ji,jj-1) 812 !!$ ! ... square of the norm of grad(v) 813 !!$ z4nor2 = z2dx * z2dx + z2dy * z2dy 814 !!$ ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 815 !!$ zdt = unbnd(ji,jk,nibm,nitm2) - unbnd(ji,jk,nibm,nit) 816 !!$ ! ... i-phase speed ratio (bounded by 1) and save the unbounded phase 817 !!$ ! velocity ratio no divided by e1f for the tracer radiation 818 !!$ IF( z4nor2 == 0.) THEN 819 !!$ z4nor2=.000001 820 !!$ END IF 821 !!$ z05cx = zdt * z2dx / z4nor2 822 !!$ u_cynbnd(ji,jk) = z05cx *unmsk(ji,jk) 823 !!$ END DO 824 !!$ END DO 825 !!$ END DO 826 !!$ IF( lk_mpp ) CALL mppobc(u_cynbnd,jpind,jpinf,jpjnob+1,jpk,1,jpi, numout ) 827 !!$ 828 !!$ ! ... extremeties njn0,njn1 829 !!$ ii = jpind + 1 - nimpp 830 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 831 !!$ DO jk = 1, jpkm1 832 !!$ u_cynbnd(ii,jk) = u_cynbnd(ii+1,jk) 833 !!$ END DO 834 !!$ END IF 835 !!$ ii = jpinf + 1 - nimpp 836 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 837 !!$ DO jk = 1, jpkm1 838 !!$ u_cynbnd(ii,jk) = u_cynbnd(ii-1,jk) 839 !!$ END DO 840 !!$ END IF 841 !!$ 842 !!$ ! 2.2 Calculate the normal velocity based on phase velocity v_cynbnd 843 !!$ ! ------------------------------------------------------------------ 844 !!$ ! 845 !!$ ! ji-row ji-row 846 !!$ ! | 847 !!$ ! /////|///////////////// 848 !!$ ! nib -----f----v----f---- jpjnob 849 !!$ ! | | 850 !!$ ! nib - u -- T -- u ---- jpjnob 851 !!$ ! | | 852 !!$ ! nibm -----f----v----f---- jpjnob-1 853 !!$ ! | | 854 !!$ ! nibm -- u -- T -- u --- jpjnob-1 855 !!$ ! | | 856 !!$ ! nibm2 -----f----v----f---- jpjnob-2 857 !!$ ! | | 858 !!$ ! ... Free surface formulation: 859 !!$ ! ... radiative conditions on the total part + relaxation toward climatology 860 !!$ ! ... jpjnob,(jpindp1, jpinfm1) 861 !!$ DO jj = fs_njn0, fs_njn1 ! Vector opt. 862 !!$ DO jk = 1, jpkm1 863 !!$ DO ji = 2, jpim1 864 !!$ ! ... 2* gradj(v) (T-point i=nibm, time mean) 865 !!$ ii = ji -1 + nimpp 866 !!$ z2dx = ( vnbnd(ji,jk,nibm ,nit) + vnbnd(ji,jk,nibm ,nitm2) & 867 !!$ - 2.*vnbnd(ji,jk,nibm2,nitm)) / e2t(ji,jj-1) 868 !!$ ! ... 2* gradi(v) (v-point i=nibm, time nitm) 869 !!$ z2dy = ( vnbnd(ji+1,jk,nibm,nitm) - vnbnd(ji-1,jk,nibm,nitm) ) / e1v(ji,jj-1) 870 !!$ ! ... square of the norm of grad(u) 871 !!$ z4nor2 = z2dx * z2dx + z2dy * z2dy 872 !!$ ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 873 !!$ zdt = vnbnd(ji,jk,nibm,nitm2) - vnbnd(ji,jk,nibm,nit) 874 !!$ ! ... j-phase speed ratio (bounded by 1) 875 !!$ IF( z4nor2 == 0. ) THEN 876 !!$ z4nor2=.00001 877 !!$ END IF 878 !!$ z05cx = zdt * z2dx / z4nor2 879 !!$ v_cynbnd(ji,jk)=z05cx *vnmsk(ji,jk) 880 !!$ END DO 881 !!$ END DO 882 !!$ END DO 883 !!$ 884 !!$ END IF 885 !!$ 886 !!$ END SUBROUTINE obc_rad_north 887 !!$ 888 !!$ 889 !!$ SUBROUTINE obc_rad_south ( kt ) 890 !!$ !!------------------------------------------------------------------------------ 891 !!$ !! *** SUBROUTINE obc_rad_south *** 892 !!$ !! 893 !!$ !! ** Purpose : 894 !!$ !! Perform swap of arrays to calculate radiative phase speeds at the open 895 !!$ !! south boundary and calculate those phase speeds if this OBC is not fixed. 896 !!$ !! In case of fixed OBC, this subrountine is not called. 897 !!$ !! 898 !!$ !! History : 899 !!$ !! ! 95-03 (J.-M. Molines) Original from SPEM 900 !!$ !! ! 97-07 (G. Madec, J.-M. Molines) additions 901 !!$ !! ! 97-12 (M. Imbard) Mpp adaptation 902 !!$ !! ! 00-06 (J.-M. Molines) 903 !!$ !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Free surface, F90 904 !!$ !!------------------------------------------------------------------------------ 905 !!$ !! * Arguments 906 !!$ INTEGER, INTENT( in ) :: kt 907 !!$ 908 !!$ !! * Local declarations 909 !!$ INTEGER :: ii 910 !!$ REAL(wp) :: z05cx, zdt, z4nor2, z2dx, z2dy 911 !!$ REAL(wp) :: zvcb, zvcbm, zvcbm2 912 !!$ !!------------------------------------------------------------------------------ 913 !!$ 914 !!$ ! 1. Swap arrays before calculating radiative velocities 915 !!$ ! ------------------------------------------------------ 916 !!$ 917 !!$ ! 1.1 zonal velocity 918 !!$ ! -------------------- 919 !!$ 920 !!$ IF( kt > nit000 .OR. ln_rstart ) THEN 921 !!$ 922 !!$ ! ... advance in time (time filter, array swap) 923 !!$ DO jk = 1, jpkm1 924 !!$ DO ji = 1, jpi 925 !!$ ! ... fields nitm2 <== nitm 926 !!$ usbnd(ji,jk,nib ,nitm2) = usbnd(ji,jk,nib ,nitm)*usmsk(ji,jk) 927 !!$ usbnd(ji,jk,nibm ,nitm2) = usbnd(ji,jk,nibm ,nitm)*usmsk(ji,jk) 928 !!$ usbnd(ji,jk,nibm2,nitm2) = usbnd(ji,jk,nibm2,nitm)*usmsk(ji,jk) 929 !!$ END DO 930 !!$ END DO 931 !!$ 932 !!$ DO jj = fs_njs0, fs_njs1 ! Vector opt. 933 !!$ DO jk = 1, jpkm1 934 !!$ DO ji = 1, jpi 935 !!$ usbnd(ji,jk,nib ,nitm) = usbnd(ji,jk,nib, nit)*usmsk(ji,jk) 936 !!$ usbnd(ji,jk,nibm ,nitm) = usbnd(ji,jk,nibm ,nit)*usmsk(ji,jk) 937 !!$ usbnd(ji,jk,nibm2,nitm) = usbnd(ji,jk,nibm2,nit)*usmsk(ji,jk) 938 !!$ ! ... fields nit <== now (kt+1) 939 !!$ usbnd(ji,jk,nib ,nit) = un(ji,jj ,jk)*usmsk(ji,jk) 940 !!$ usbnd(ji,jk,nibm ,nit) = un(ji,jj+1,jk)*usmsk(ji,jk) 941 !!$ usbnd(ji,jk,nibm2,nit) = un(ji,jj+2,jk)*usmsk(ji,jk) 942 !!$ END DO 943 !!$ END DO 944 !!$ END DO 945 !!$ IF( lk_mpp ) CALL mppobc(usbnd,jpisd,jpisf,jpjsob,jpk*3*3,1,jpi, numout ) 946 !!$ 947 !!$ ! ... extremeties njs0,njs1 948 !!$ ii = jpisd + 1 - nimpp 949 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 950 !!$ DO jk = 1, jpkm1 951 !!$ usbnd(ii,jk,nibm,nitm) = usbnd(ii+1,jk,nibm,nitm) 952 !!$ END DO 953 !!$ END IF 954 !!$ ii = jpisf + 1 - nimpp 955 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 956 !!$ DO jk = 1, jpkm1 957 !!$ usbnd(ii,jk,nibm,nitm) = usbnd(ii-1,jk,nibm,nitm) 958 !!$ END DO 959 !!$ END IF 960 !!$ 961 !!$ ! 1.2 normal velocity 962 !!$ ! ------------------- 963 !!$ 964 !!$ !.. advance in time (time filter, array swap) 965 !!$ DO jk = 1, jpkm1 966 !!$ DO ji = 1, jpi 967 !!$ ! ... fields nitm2 <== nitm 968 !!$ vsbnd(ji,jk,nib ,nitm2) = vsbnd(ji,jk,nib ,nitm)*vsmsk(ji,jk) 969 !!$ vsbnd(ji,jk,nibm ,nitm2) = vsbnd(ji,jk,nibm ,nitm)*vsmsk(ji,jk) 970 !!$ END DO 971 !!$ END DO 972 !!$ 973 !!$ DO jj = fs_njs0, fs_njs1 ! Vector opt. 974 !!$ DO jk = 1, jpkm1 975 !!$ DO ji = 1, jpi 976 !!$ vsbnd(ji,jk,nib ,nitm) = vsbnd(ji,jk,nib, nit)*vsmsk(ji,jk) 977 !!$ vsbnd(ji,jk,nibm ,nitm) = vsbnd(ji,jk,nibm ,nit)*vsmsk(ji,jk) 978 !!$ vsbnd(ji,jk,nibm2,nitm) = vsbnd(ji,jk,nibm2,nit)*vsmsk(ji,jk) 979 !!$ ! ... total or baroclinic velocity at b, bm and bm2 980 !!$ zvcb = vn (ji,jj,jk) 981 !!$ zvcbm = vn (ji,jj+1,jk) 982 !!$ zvcbm2 = vn (ji,jj+2,jk) 983 !!$ ! ... fields nit <== now (kt+1) 984 !!$ vsbnd(ji,jk,nib ,nit) = zvcb *vsmsk(ji,jk) 985 !!$ vsbnd(ji,jk,nibm ,nit) = zvcbm *vsmsk(ji,jk) 986 !!$ vsbnd(ji,jk,nibm2,nit) = zvcbm2 *vsmsk(ji,jk) 987 !!$ END DO 988 !!$ END DO 989 !!$ END DO 990 !!$ IF( lk_mpp ) CALL mppobc(vsbnd,jpisd,jpisf,jpjsob,jpk*3*3,1,jpi, numout ) 991 !!$ 992 !!$ ! ... extremeties njs0,njs1 993 !!$ ii = jpisd + 1 - nimpp 994 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 995 !!$ DO jk = 1, jpkm1 996 !!$ vsbnd(ii,jk,nibm,nitm) = vsbnd(ii+1,jk,nibm,nitm) 997 !!$ END DO 998 !!$ END IF 999 !!$ ii = jpisf + 1 - nimpp 1000 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 1001 !!$ DO jk = 1, jpkm1 1002 !!$ vsbnd(ii,jk,nibm,nitm) = vsbnd(ii-1,jk,nibm,nitm) 1003 !!$ END DO 1004 !!$ END IF 1005 !!$ 1006 !!$ ! 1.3 Temperature and salinity 1007 !!$ ! ---------------------------- 1008 !!$ 1009 !!$ ! ... advance in time (time filter, array swap) 1010 !!$ DO jk = 1, jpkm1 1011 !!$ DO ji = 1, jpi 1012 !!$ ! ... fields nitm <== nit plus time filter at the boundary 1013 !!$ tsbnd(ji,jk,nib,nitm) = tsbnd(ji,jk,nib,nit)*tsmsk(ji,jk) 1014 !!$ ssbnd(ji,jk,nib,nitm) = ssbnd(ji,jk,nib,nit)*tsmsk(ji,jk) 1015 !!$ END DO 1016 !!$ END DO 1017 !!$ 1018 !!$ DO jj = fs_njs0, fs_njs1 ! Vector opt. 1019 !!$ DO jk = 1, jpkm1 1020 !!$ DO ji = 1, jpi 1021 !!$ tsbnd(ji,jk,nibm ,nitm) = tsbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk) 1022 !!$ ssbnd(ji,jk,nibm ,nitm) = ssbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk) 1023 !!$ ! ... fields nit <== now (kt+1) 1024 !!$ tsbnd(ji,jk,nib ,nit) = tn(ji,jj ,jk)*tsmsk(ji,jk) 1025 !!$ tsbnd(ji,jk,nibm ,nit) = tn(ji,jj+1 ,jk)*tsmsk(ji,jk) 1026 !!$ ssbnd(ji,jk,nib ,nit) = sn(ji,jj ,jk)*tsmsk(ji,jk) 1027 !!$ ssbnd(ji,jk,nibm ,nit) = sn(ji,jj+1 ,jk)*tsmsk(ji,jk) 1028 !!$ END DO 1029 !!$ END DO 1030 !!$ END DO 1031 !!$ IF( lk_mpp ) CALL mppobc(tsbnd,jpisd,jpisf,jpjsob,jpk*2*2,1,jpi, numout ) 1032 !!$ IF( lk_mpp ) CALL mppobc(ssbnd,jpisd,jpisf,jpjsob,jpk*2*2,1,jpi, numout ) 1033 !!$ 1034 !!$ ! ... extremeties njs0,njs1 1035 !!$ ii = jpisd + 1 - nimpp 1036 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 1037 !!$ DO jk = 1, jpkm1 1038 !!$ tsbnd(ii,jk,nibm,nitm) = tsbnd(ii+1,jk,nibm,nitm) 1039 !!$ ssbnd(ii,jk,nibm,nitm) = ssbnd(ii+1,jk,nibm,nitm) 1040 !!$ END DO 1041 !!$ END IF 1042 !!$ ii = jpisf + 1 - nimpp 1043 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 1044 !!$ DO jk = 1, jpkm1 1045 !!$ tsbnd(ii,jk,nibm,nitm) = tsbnd(ii-1,jk,nibm,nitm) 1046 !!$ ssbnd(ii,jk,nibm,nitm) = ssbnd(ii-1,jk,nibm,nitm) 1047 !!$ END DO 1048 !!$ END IF 1049 !!$ 1050 !!$ END IF ! End of array swap 1051 !!$ 1052 !!$ ! 2 - Calculation of radiation velocities 1053 !!$ ! --------------------------------------- 1054 !!$ 1055 !!$ IF( kt >= nit000 +3 .OR. ln_rstart ) THEN 1056 !!$ 1057 !!$ ! 2.1 Calculate the normal velocity based on phase velocity u_cysbnd 1058 !!$ ! ------------------------------------------------------------------- 1059 !!$ ! 1060 !!$ ! ji-row 1061 !!$ ! | 1062 !!$ ! nibm2 -----f----- jpjsob +2 1063 !!$ ! | 1064 !!$ ! nibm2 -- u ----- jpjsob +2 1065 !!$ ! | 1066 !!$ ! nibm -----f----- jpjsob +1 1067 !!$ ! | 1068 !!$ ! nibm -- u ----- jpjsob +1 1069 !!$ ! | 1070 !!$ ! nib -----f----- jpjsob 1071 !!$ ! /////|////// 1072 !!$ ! nib ////u///// jpjsob 1073 !!$ ! 1074 !!$ ! ... radiative condition plus Raymond-Kuo 1075 !!$ ! ... jpjsob,(jpisdp1, jpisfm1) 1076 !!$ DO jj = fs_njs0, fs_njs1 ! Vector opt. 1077 !!$ DO jk = 1, jpkm1 1078 !!$ DO ji = 2, jpim1 1079 !!$ ! ... 2* j-gradient of u (f-point i=nibm, time mean) 1080 !!$ z2dx = (- usbnd(ji,jk,nibm ,nit) - usbnd(ji,jk,nibm ,nitm2) & 1081 !!$ + 2.*usbnd(ji,jk,nibm2,nitm) ) / e2f(ji,jj+1) 1082 !!$ ! ... 2* i-gradient of u (u-point i=nibm, time nitm) 1083 !!$ z2dy = ( usbnd(ji+1,jk,nibm,nitm) - usbnd(ji-1,jk,nibm,nitm) ) / e1u(ji, jj+1) 1084 !!$ ! ... square of the norm of grad(v) 1085 !!$ z4nor2 = z2dx * z2dx + z2dy * z2dy 1086 !!$ IF( z4nor2 == 0.) THEN 1087 !!$ z4nor2 = 0.000001 1088 !!$ END IF 1089 !!$ ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 1090 !!$ zdt = usbnd(ji,jk,nibm,nitm2) - usbnd(ji,jk,nibm,nit) 1091 !!$ ! ... i-phase speed ratio (bounded by -1) and save the unbounded phase 1092 !!$ ! velocity ratio no divided by e1f for the tracer radiation 1093 !!$ z05cx = zdt * z2dx / z4nor2 1094 !!$ u_cysbnd(ji,jk) = z05cx*usmsk(ji,jk) 1095 !!$ END DO 1096 !!$ END DO 1097 !!$ END DO 1098 !!$ IF( lk_mpp ) CALL mppobc(u_cysbnd,jpisd,jpisf,jpjsob,jpk,1,jpi, numout ) 1099 !!$ 1100 !!$ ! ... extremeties njs0,njs1 1101 !!$ ii = jpisd + 1 - nimpp 1102 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 1103 !!$ DO jk = 1, jpkm1 1104 !!$ u_cysbnd(ii,jk) = u_cysbnd(ii+1,jk) 1105 !!$ END DO 1106 !!$ END IF 1107 !!$ ii = jpisf + 1 - nimpp 1108 !!$ IF( ii >= 2 .AND. ii < jpim1 ) THEN 1109 !!$ DO jk = 1, jpkm1 1110 !!$ u_cysbnd(ii,jk) = u_cysbnd(ii-1,jk) 1111 !!$ END DO 1112 !!$ END IF 1113 !!$ 1114 !!$ ! 2.2 Calculate the normal velocity based on phase velocity v_cysbnd 1115 !!$ ! ------------------------------------------------------------------- 1116 !!$ ! 1117 !!$ ! ji-row ji-row 1118 !!$ ! | | 1119 !!$ ! nibm2 -----f----v----f---- jpjsob+2 1120 !!$ ! | | 1121 !!$ ! nibm - u -- T -- u ---- jpjsob+2 1122 !!$ ! | | 1123 !!$ ! nibm -----f----v----f---- jpjsob+1 1124 !!$ ! | | 1125 !!$ ! nib -- u -- T -- u --- jpjsob+1 1126 !!$ ! | | 1127 !!$ ! nib -----f----v----f---- jpjsob 1128 !!$ ! ///////////////////// 1129 !!$ ! 1130 !!$ ! ... Free surface formulation: 1131 !!$ ! ... radiative conditions on the total part + relaxation toward climatology 1132 !!$ ! ... jpjsob,(jpisdp1,jpisfm1) 1133 !!$ DO jj = fs_njs0, fs_njs1 ! Vector opt. 1134 !!$ DO jk = 1, jpkm1 1135 !!$ DO ji = 2, jpim1 1136 !!$ ! ... 2* gradj(v) (T-point i=nibm, time mean) 1137 !!$ z2dx = ( - vsbnd(ji,jk,nibm ,nit) - vsbnd(ji,jk,nibm ,nitm2) & 1138 !!$ + 2.*vsbnd(ji,jk,nibm2,nitm) ) / e2t(ji,jj+1) 1139 !!$ ! ... 2* gradi(v) (v-point i=nibm, time nitm) 1140 !!$ z2dy = ( vsbnd(ji+1,jk,nibm,nitm) - vsbnd(ji-1,jk,nibm,nitm) ) / e1v(ji,jj+1) 1141 !!$ ! ... square of the norm of grad(u) 1142 !!$ z4nor2 = z2dx * z2dx + z2dy * z2dy 1143 !!$ IF( z4nor2 == 0.) THEN 1144 !!$ z4nor2 = 0.000001 1145 !!$ END IF 1146 !!$ ! ... minus time derivative (leap-frog) at nibm, without / 2 dt 1147 !!$ zdt = vsbnd(ji,jk,nibm,nitm2) - vsbnd(ji,jk,nibm,nit) 1148 !!$ ! ... j-phase speed ratio (bounded by -1) 1149 !!$ z05cx = zdt * z2dx / z4nor2 1150 !!$ v_cysbnd(ji,jk)=z05cx*vsmsk(ji,jk) 1151 !!$ END DO 1152 !!$ END DO 1153 !!$ END DO 1154 !!$ 1155 !!$ ENDIF 1156 !!$ 1157 !!$ END SUBROUTINE obc_rad_south 1158 !!$ 1159 !!$#else 1160 1160 !!================================================================================= 1161 1161 !! *** MODULE obcrad *** -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obctra.F90
r2528 r2797 1 1 MODULE obctra 2 !!====================================================================== ===========2 !!====================================================================== 3 3 !! *** MODULE obctra *** 4 !! Ocean tracers: Radiation of tracers on each open boundary 5 !!================================================================================= 4 !! Ocean tracers: Flow Relaxation Scheme of tracers on each open boundary 5 !!====================================================================== 6 !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code 7 !! 3.0 ! 2008-04 (NEMO team) add in the reference version 8 !!---------------------------------------------------------------------- 6 9 #if defined key_obc 7 !!--------------------------------------------------------------------------------- 8 !! 'key_obc' : Open Boundary Conditions 9 !!--------------------------------------------------------------------------------- 10 !! obc_tra : call the subroutine for each open boundary 11 !! obc_tra_east : radiation of the east open boundary tracers 12 !! obc_tra_west : radiation of the west open boundary tracers 13 !! obc_tra_north : radiation of the north open boundary tracers 14 !! obc_tra_south : radiation of the south open boundary tracers 15 !!---------------------------------------------------------------------------------- 16 !! * Modules used 10 !!---------------------------------------------------------------------- 11 !! 'key_obc' Unstructured Open Boundary Conditions 12 !!---------------------------------------------------------------------- 13 !! obc_tra : Apply open boundary conditions to T and S 14 !! obc_tra_frs : Apply Flow Relaxation Scheme 15 !!---------------------------------------------------------------------- 17 16 USE oce ! ocean dynamics and tracers variables 18 17 USE dom_oce ! ocean space and time domain variables 19 USE phycst ! physical constants20 18 USE obc_oce ! ocean open boundary conditions 21 USE lib_mpp ! ???22 USE lbclnk ! ???19 USE obcdta, ONLY: bf 20 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 23 21 USE in_out_manager ! I/O manager 24 22 … … 26 24 PRIVATE 27 25 28 !! * Accessibility 29 PUBLIC obc_tra ! routine called in tranxt.F90 26 PUBLIC obc_tra ! routine called in tranxt.F90 30 27 31 !! * Module variables 32 INTEGER :: & ! ... boundary space indices 33 nib = 1, & ! nib = boundary point 34 nibm = 2, & ! nibm = 1st interior point 35 nibm2 = 3, & ! nibm2 = 2nd interior point 36 ! ... boundary time indices 37 nit = 1, & ! nit = now 38 nitm = 2, & ! nitm = before 39 nitm2 = 3 ! nitm2 = before-before 40 41 REAL(wp) :: & 42 rtaue , rtauw , rtaun , rtaus , & ! Boundary restoring coefficient 43 rtauein, rtauwin, rtaunin, rtausin ! Boundary restoring coefficient for inflow 44 45 !! * Substitutions 46 # include "obc_vectopt_loop_substitute.h90" 47 !!--------------------------------------------------------------------------------- 28 !!---------------------------------------------------------------------- 48 29 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 49 30 !! $Id$ 50 31 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 51 !!--------------------------------------------------------------------------------- 52 32 !!---------------------------------------------------------------------- 53 33 CONTAINS 54 34 55 35 SUBROUTINE obc_tra( kt ) 56 !!------------------------------------------------------------------------------- 57 !! *** SUBROUTINE obc_tra *** 58 !! 59 !! ** Purpose : Compute tracer fields (t,s) along the open boundaries. 60 !! This routine is called by the tranxt.F routine and updates ta,sa 61 !! which are the actual temperature and salinity fields. 62 !! The logical variable lp_obc_east, and/or lp_obc_west, and/or lp_obc_north, 63 !! and/or lp_obc_south allow the user to determine which boundary is an 64 !! open one (must be done in the param_obc.h90 file). 36 !!---------------------------------------------------------------------- 37 !! *** SUBROUTINE obc_dyn3d *** 65 38 !! 66 !! Reference : 67 !! Marchesiello P., 1995, these de l'universite J. Fourier, Grenoble, France. 39 !! ** Purpose : - Apply open boundary conditions for baroclinic velocities 68 40 !! 69 !! History :70 !! ! 95-03 (J.-M. Molines) Original, SPEM71 !! ! 97-07 (G. Madec, J.-M. Molines) addition72 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) F9073 41 !!---------------------------------------------------------------------- 74 !! * Arguments75 INTEGER, INTENT( in ) :: kt76 !!----------------------------------------------------------------------42 INTEGER, INTENT( in ) :: kt ! Main time step counter 43 !! 44 INTEGER :: ib_obc ! Loop index 77 45 78 ! 0. Local constant initialization46 DO ib_obc=1, nb_obc 79 47 80 IF( kt == nit000 .OR. ln_rstart) THEN 81 ! ... Boundary restoring coefficient 82 rtaue = 2. * rdt / rdpeob 83 rtauw = 2. * rdt / rdpwob 84 rtaun = 2. * rdt / rdpnob 85 rtaus = 2. * rdt / rdpsob 86 ! ... Boundary restoring coefficient for inflow ( all boundaries) 87 rtauein = 2. * rdt / rdpein 88 rtauwin = 2. * rdt / rdpwin 89 rtaunin = 2. * rdt / rdpnin 90 rtausin = 2. * rdt / rdpsin 91 END IF 92 93 IF( lp_obc_east ) CALL obc_tra_east ( kt ) ! East open boundary 94 95 IF( lp_obc_west ) CALL obc_tra_west ( kt ) ! West open boundary 96 97 IF( lp_obc_north ) CALL obc_tra_north( kt ) ! North open boundary 98 99 IF( lp_obc_south ) CALL obc_tra_south( kt ) ! South open boundary 100 101 IF( lk_mpp ) THEN !!bug ??? 102 IF( kt >= nit000+3 .AND. ln_rstart ) THEN 103 CALL lbc_lnk( tb, 'T', 1. ) 104 CALL lbc_lnk( sb, 'T', 1. ) 105 END IF 106 CALL lbc_lnk( ta, 'T', 1. ) 107 CALL lbc_lnk( sa, 'T', 1. ) 108 ENDIF 48 SELECT CASE( nn_tra(ib_obc) ) 49 CASE(jp_none) 50 CYCLE 51 CASE(jp_frs) 52 CALL obc_tra_frs( idx_obc(ib_obc), dta_obc(ib_obc), kt ) 53 CASE DEFAULT 54 CALL ctl_stop( 'obc_tra : unrecognised option for open boundaries for T an S' ) 55 END SELECT 56 ENDDO 109 57 110 58 END SUBROUTINE obc_tra 111 59 112 113 SUBROUTINE obc_tra_east ( kt ) 114 !!------------------------------------------------------------------------------ 115 !! *** SUBROUTINE obc_tra_east *** 116 !! 117 !! ** Purpose : 118 !! Apply the radiation algorithm on east OBC tracers ta, sa using the 119 !! phase velocities calculated in obc_rad_east subroutine in obcrad.F90 module 120 !! If the logical lfbceast is .TRUE., there is no radiation but only fixed OBC 121 !! 122 !! History : 123 !! ! 95-03 (J.-M. Molines) Original from SPEM 124 !! ! 97-07 (G. Madec, J.-M. Molines) additions 125 !! ! 97-12 (M. Imbard) Mpp adaptation 126 !! ! 00-06 (J.-M. Molines) 127 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) F90 128 !!------------------------------------------------------------------------------ 129 !! * Arguments 130 INTEGER, INTENT( in ) :: kt 131 132 !! * Local declaration 133 INTEGER :: ji, jj, jk ! dummy loop indices 134 REAL(wp) :: z05cx, ztau, zin 135 !!------------------------------------------------------------------------------ 136 137 ! 1. First three time steps and more if lfbceast is .TRUE. 138 ! In that case open boundary conditions are FIXED. 139 ! -------------------------------------------------------- 140 141 IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbceast ) THEN 142 DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 143 DO jk = 1, jpkm1 144 DO jj = 1, jpj 145 ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - temsk(jj,jk)) + & 146 tfoe(jj,jk)*temsk(jj,jk) 147 sa(ji,jj,jk) = sa(ji,jj,jk) * (1. - temsk(jj,jk)) + & 148 sfoe(jj,jk)*temsk(jj,jk) 149 END DO 150 END DO 60 SUBROUTINE obc_tra_frs( idx, dta, kt ) 61 !!---------------------------------------------------------------------- 62 !! *** SUBROUTINE obc_tra_frs *** 63 !! 64 !! ** Purpose : Apply the Flow Relaxation Scheme for tracers at open boundaries. 65 !! 66 !! Reference : Engedahl H., 1995, Tellus, 365-382. 67 !!---------------------------------------------------------------------- 68 INTEGER, INTENT(in) :: kt 69 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 70 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 71 !! 72 REAL(wp) :: zwgt ! boundary weight 73 INTEGER :: ib, ik, igrd ! dummy loop indices 74 INTEGER :: ii, ij ! 2D addresses 75 !!---------------------------------------------------------------------- 76 ! 77 ! 78 igrd = 1 ! Everything is at T-points here 79 DO ib = 1, idx%nblen(igrd) 80 DO ik = 1, jpkm1 81 ii = idx%nbi(ib,igrd) 82 ij = idx%nbj(ib,igrd) 83 zwgt = idx%nbw(ib,igrd) 84 ta(ii,ij,ik) = ( ta(ii,ij,ik) + zwgt * ( dta%tem(ib,ik) - ta(ii,ij,ik) ) ) * tmask(ii,ij,ik) 85 sa(ii,ij,ik) = ( sa(ii,ij,ik) + zwgt * ( dta%sal(ib,ik) - sa(ii,ij,ik) ) ) * tmask(ii,ij,ik) 151 86 END DO 152 153 ELSE 154 155 ! 2. Beyond the fourth time step if lfbceast is .FALSE. 156 ! ----------------------------------------------------- 157 158 ! Temperature and salinity radiation 159 ! ---------------------------------- 160 ! 161 ! nibm2 nibm nib 162 ! | nibm | nib///|/// 163 ! | | | |////|/// 164 ! jj line --v----f----v----f----v--- 165 ! | | | |////|/// 166 ! | |/// // 167 ! jj line T u T u/// T // 168 ! | |/// // 169 ! | | | |////|/// 170 ! jj-1 line --v----f----v----f----v--- 171 ! | | | |////|/// 172 ! jpieob-1 jpieob / /// 173 ! | | | 174 ! jpieob-1 jpieob jpieob+1 175 ! 176 ! ... radiative conditions + relaxation toward a climatology 177 ! the phase velocity is taken as the phase velocity of the tangen- 178 ! tial velocity (here vn), which have been saved in (u_cxebnd,v_cxebnd) 179 ! ... (jpjedp1, jpjefm1), jpieob+1 180 DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 181 DO jk = 1, jpkm1 182 DO jj = 2, jpjm1 183 ! ... i-phase speed ratio (from averaged of v_cxebnd) 184 z05cx = ( 0.5 * ( v_cxebnd(jj,jk) + v_cxebnd(jj-1,jk) ) ) / e1t(ji-1,jj) 185 z05cx = min( z05cx, 1. ) 186 ! ... z05cx=< 0, inflow zin=0, ztau=1 187 ! > 0, outflow zin=1, ztau=rtaue 188 zin = sign( 1., z05cx ) 189 zin = 0.5*( zin + abs(zin) ) 190 ! ... for inflow rtauein is used for relaxation coefficient else rtaue 191 ztau = (1.-zin ) * rtauein + zin * rtaue 192 z05cx = z05cx * zin 193 ! ... update ( ta, sa ) with radiative or climatological (t, s) 194 ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - temsk(jj,jk)) + & 195 temsk(jj,jk) * ( ( 1. - z05cx - ztau ) & 196 * tebnd(jj,jk,nib ,nitm) + 2.*z05cx & 197 * tebnd(jj,jk,nibm,nit ) + ztau * tfoe (jj,jk) ) & 198 / (1. + z05cx) 199 sa(ji,jj,jk) = sa(ji,jj,jk) * (1. - temsk(jj,jk)) + & 200 temsk(jj,jk) * ( ( 1. - z05cx - ztau ) & 201 * sebnd(jj,jk,nib ,nitm) + 2.*z05cx & 202 * sebnd(jj,jk,nibm,nit ) + ztau * sfoe (jj,jk) ) & 203 / (1. + z05cx) 204 END DO 205 END DO 206 END DO 207 208 END IF 209 210 END SUBROUTINE obc_tra_east 211 212 213 SUBROUTINE obc_tra_west ( kt ) 214 !!------------------------------------------------------------------------------ 215 !! *** SUBROUTINE obc_tra_west *** 216 !! 217 !! ** Purpose : 218 !! Apply the radiation algorithm on west OBC tracers ta, sa using the 219 !! phase velocities calculated in obc_rad_west subroutine in obcrad.F90 module 220 !! If the logical lfbcwest is .TRUE., there is no radiation but only fixed OBC 221 !! 222 !! History : 223 !! ! 95-03 (J.-M. Molines) Original from SPEM 224 !! ! 97-07 (G. Madec, J.-M. Molines) additions 225 !! ! 97-12 (M. Imbard) Mpp adaptation 226 !! ! 00-06 (J.-M. Molines) 227 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) F90 228 !!------------------------------------------------------------------------------ 229 !! * Arguments 230 INTEGER, INTENT( in ) :: kt 231 232 !! * Local declaration 233 INTEGER :: ji, jj, jk ! dummy loop indices 234 REAL(wp) :: z05cx, ztau, zin 235 !!------------------------------------------------------------------------------ 236 237 ! 1. First three time steps and more if lfbcwest is .TRUE. 238 ! In that case open boundary conditions are FIXED. 239 ! -------------------------------------------------------- 240 241 IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcwest ) THEN 242 243 DO ji = fs_niw0, fs_niw1 ! Vector opt. 244 DO jk = 1, jpkm1 245 DO jj = 1, jpj 246 ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - twmsk(jj,jk)) + & 247 tfow(jj,jk)*twmsk(jj,jk) 248 sa(ji,jj,jk) = sa(ji,jj,jk) * (1. - twmsk(jj,jk)) + & 249 sfow(jj,jk)*twmsk(jj,jk) 250 END DO 251 END DO 252 END DO 253 254 ELSE 255 256 ! 2. Beyond the fourth time step if lfbcwest is .FALSE. 257 ! ----------------------------------------------------- 258 259 ! Temperature and salinity radiation 260 ! ---------------------------------- 261 ! 262 ! nib nibm nibm2 263 ! nib///| nibm | nibm2 | 264 ! ///|////| | | | | 265 ! ---v----f----v----f----v----f-- jj line 266 ! ///|////| | | | | 267 ! // ///| | | 268 ! // T ///u T u T u jj line 269 ! // ///| | | 270 ! ///|////| | | | | 271 ! ---v----f----v----f----v----f-- jj-1 line 272 ! ///|////| | | | | 273 ! jpiwob jpiwob+1 jpiwob+2 274 ! | | | 275 ! jpiwob jpiwob+1 jpiwob+2 276 ! 277 ! ... radiative conditions + relaxation toward a climatology 278 ! ... the phase velocity is taken as the phase velocity of the tangen- 279 ! ... tial velocity (here vn), which have been saved in (v_cxwbnd) 280 DO ji = fs_niw0, fs_niw1 ! Vector opt. 281 DO jk = 1, jpkm1 282 DO jj = 2, jpjm1 283 ! ... i-phase speed ratio (from averaged of v_cxwbnd) 284 z05cx = ( 0.5 * ( v_cxwbnd(jj,jk) + v_cxwbnd(jj-1,jk) ) ) / e1t(ji+1,jj) 285 z05cx = max( z05cx, -1. ) 286 ! ... z05cx > 0, inflow zin=0, ztau=1 287 ! < 0, outflow zin=1, ztau=rtauw 288 zin = sign( 1., -1.* z05cx ) 289 zin = 0.5*( zin + abs(zin) ) 290 ztau = (1.-zin )*rtauwin + zin * rtauw 291 z05cx = z05cx * zin 292 ! ... update (ta,sa) with radiative or climatological (t, s) 293 ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - twmsk(jj,jk)) + & 294 twmsk(jj,jk) * ( ( 1. + z05cx - ztau ) & 295 * twbnd(jj,jk,nib ,nitm) - 2.*z05cx & 296 * twbnd(jj,jk,nibm,nit ) + ztau * tfow (jj,jk) ) & 297 / (1. - z05cx) 298 sa(ji,jj,jk) = sa(ji,jj,jk) * (1. - twmsk(jj,jk)) + & 299 twmsk(jj,jk) * ( ( 1. + z05cx - ztau ) & 300 * swbnd(jj,jk,nib ,nitm) - 2.*z05cx & 301 * swbnd(jj,jk,nibm,nit ) + ztau * sfow (jj,jk) ) & 302 / (1. - z05cx) 303 END DO 304 END DO 305 END DO 306 307 END IF 308 309 END SUBROUTINE obc_tra_west 310 311 312 SUBROUTINE obc_tra_north ( kt ) 313 !!------------------------------------------------------------------------------ 314 !! *** SUBROUTINE obc_tra_north *** 315 !! 316 !! ** Purpose : 317 !! Apply the radiation algorithm on north OBC tracers ta, sa using the 318 !! phase velocities calculated in obc_rad_north subroutine in obcrad.F90 module 319 !! If the logical lfbcnorth is .TRUE., there is no radiation but only fixed OBC 320 !! 321 !! History : 322 !! ! 95-03 (J.-M. Molines) Original from SPEM 323 !! ! 97-07 (G. Madec, J.-M. Molines) additions 324 !! ! 97-12 (M. Imbard) Mpp adaptation 325 !! ! 00-06 (J.-M. Molines) 326 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) F90 327 !!------------------------------------------------------------------------------ 328 !! * Arguments 329 INTEGER, INTENT( in ) :: kt 330 331 !! * Local declaration 332 INTEGER :: ji, jj, jk ! dummy loop indices 333 REAL(wp) :: z05cx, ztau, zin 334 !!------------------------------------------------------------------------------ 335 336 ! 1. First three time steps and more if lfbcnorth is .TRUE. 337 ! In that case open boundary conditions are FIXED. 338 ! -------------------------------------------------------- 339 340 IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcnorth ) THEN 341 342 DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt. 343 DO jk = 1, jpkm1 344 DO ji = 1, jpi 345 ta(ji,jj,jk)= ta(ji,jj,jk) * (1.-tnmsk(ji,jk)) + & 346 tnmsk(ji,jk) * tfon(ji,jk) 347 sa(ji,jj,jk)= sa(ji,jj,jk) * (1.-tnmsk(ji,jk)) + & 348 tnmsk(ji,jk) * sfon(ji,jk) 349 END DO 350 END DO 351 END DO 352 353 ELSE 354 355 ! 2. Beyond the fourth time step if lfbcnorth is .FALSE. 356 ! ------------------------------------------------------- 357 358 ! Temperature and salinity radiation 359 ! ---------------------------------- 360 ! 361 ! ji-1 ji ji ji +1 362 ! | 363 ! nib //// u // T // u // T // jpjnob + 1 364 ! /////|////////////////// 365 ! nib ----f----v----f----v--- jpjnob 366 ! | | 367 ! nibm-- u -- T -- u -- T -- jpjnob 368 ! | | 369 ! nibm ----f----v----f----v--- jpjnob-1 370 ! | | 371 ! nibm2-- u -- T -- T -- T -- jpjnob-1 372 ! | | 373 ! nibm2 ----f----v----f----v--- jpjnob-2 374 ! | | 375 ! 376 ! ... radiative conditions + relaxation toward a climatology 377 ! ... the phase velocity is taken as the normal phase velocity of the tangen- 378 ! ... tial velocity (here un), which has been saved in (u_cynbnd) 379 ! ... jpjnob+1,(jpindp1, jpinfm1) 380 DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt. 381 DO jk = 1, jpkm1 382 DO ji = 2, jpim1 383 ! ... j-phase speed ratio (from averaged of vtnbnd) 384 ! (bounded by 1) 385 z05cx = ( 0.5 * ( u_cynbnd(ji,jk) + u_cynbnd(ji-1,jk) ) ) / e2t(ji,jj-1) 386 z05cx = min( z05cx, 1. ) 387 ! ... z05cx=< 0, inflow zin=0, ztau=1 388 ! > 0, outflow zin=1, ztau=rtaun 389 zin = sign( 1., z05cx ) 390 zin = 0.5*( zin + abs(zin) ) 391 ! ... for inflow rtaunin is used for relaxation coefficient else rtaun 392 ztau = (1.-zin ) * rtaunin + zin * rtaun 393 z05cx = z05cx * zin 394 ! ... update (ta,sa) with radiative or climatological (t, s) 395 ta(ji,jj,jk) = ta(ji,jj,jk) * (1.-tnmsk(ji,jk)) + & 396 tnmsk(ji,jk) * ( ( 1. - z05cx - ztau ) & 397 * tnbnd(ji,jk,nib ,nitm) + 2.*z05cx & 398 * tnbnd(ji,jk,nibm,nit ) + ztau * tfon (ji,jk) ) & 399 / (1. + z05cx) 400 sa(ji,jj,jk) = sa(ji,jj,jk) * (1.-tnmsk(ji,jk)) + & 401 tnmsk(ji,jk) * ( ( 1. - z05cx - ztau ) & 402 * snbnd(ji,jk,nib ,nitm) + 2.*z05cx & 403 * snbnd(ji,jk,nibm,nit ) + ztau * sfon (ji,jk) ) & 404 / (1. + z05cx) 405 END DO 406 END DO 407 END DO 408 409 END IF 410 411 END SUBROUTINE obc_tra_north 412 413 414 SUBROUTINE obc_tra_south ( kt ) 415 !!------------------------------------------------------------------------------ 416 !! *** SUBROUTINE obc_tra_south *** 417 !! 418 !! ** Purpose : 419 !! Apply the radiation algorithm on south OBC tracers ta, sa using the 420 !! phase velocities calculated in obc_rad_south subroutine in obcrad.F90 module 421 !! If the logical lfbcsouth is .TRUE., there is no radiation but only fixed OBC 422 !! 423 !! History : 424 !! ! 95-03 (J.-M. Molines) Original from SPEM 425 !! ! 97-07 (G. Madec, J.-M. Molines) additions 426 !! ! 97-12 (M. Imbard) Mpp adaptation 427 !! ! 00-06 (J.-M. Molines) 428 !! 8.5 ! 02-10 (C. Talandier, A-M Treguier) F90 429 !!------------------------------------------------------------------------------ 430 !! * Arguments 431 INTEGER, INTENT( in ) :: kt 432 433 !! * Local declaration 434 INTEGER :: ji, jj, jk ! dummy loop indices 435 REAL(wp) :: z05cx, ztau, zin 436 !!------------------------------------------------------------------------------ 437 438 ! 1. First three time steps and more if lfbcsouth is .TRUE. 439 ! In that case open boundary conditions are FIXED. 440 ! -------------------------------------------------------- 441 442 IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcsouth ) THEN 443 444 DO jj = fs_njs0, fs_njs1 ! Vector opt. 445 DO jk = 1, jpkm1 446 DO ji = 1, jpi 447 ta(ji,jj,jk)= ta(ji,jj,jk) * (1.-tsmsk(ji,jk)) + & 448 tsmsk(ji,jk) * tfos(ji,jk) 449 sa(ji,jj,jk)= sa(ji,jj,jk) * (1.-tsmsk(ji,jk)) + & 450 tsmsk(ji,jk) * sfos(ji,jk) 451 END DO 452 END DO 453 END DO 454 455 ELSE 456 457 ! 2. Beyond the fourth time step if lfbcsouth is .FALSE. 458 ! ------------------------------------------------------- 459 460 ! Temperature and salinity radiation 461 ! ---------------------------------- 462 ! 463 ! ji-1 ji ji ji +1 464 ! | | 465 ! nibm2 ----f----v----f----v--- jpjsob+2 466 ! | | 467 ! nibm2 -- u -- T -- u -- T -- jpjsob+2 468 ! | | 469 ! nibm ----f----v----f----v--- jpjsob+1 470 ! | | 471 ! nibm -- u -- T -- T -- T -- jpjsob+1 472 ! | | 473 ! nib -----f----v----f----v--- jpjsob 474 ! //////|/////////|//////// 475 ! nib //// u // T // u // T // jpjsob 476 ! 477 !... radiative conditions + relaxation toward a climatology 478 !... the phase velocity is taken as the phase velocity of the tangen- 479 !... tial velocity (here un), which has been saved in (u_cysbnd) 480 !... jpjsob,(jpisdp1, jpisfm1) 481 DO jj = fs_njs0, fs_njs1 ! Vector opt. 482 DO jk = 1, jpkm1 483 DO ji = 2, jpim1 484 !... j-phase speed ratio (from averaged of u_cysbnd) 485 ! (bounded by 1) 486 z05cx = ( 0.5 * ( u_cysbnd(ji,jk) + u_cysbnd(ji-1,jk) ) ) / e2t(ji,jj+1) 487 z05cx = max( z05cx, -1. ) 488 !... z05cx > 0, inflow zin=0, ztau=1 489 ! < 0, outflow zin=1, ztau=rtaus 490 zin = sign( 1., -1.* z05cx ) 491 zin = 0.5*( zin + abs(zin) ) 492 ztau = (1.-zin ) * rtausin + zin * rtaus 493 z05cx = z05cx * zin 494 495 !... update (ta,sa) with radiative or climatological (t, s) 496 ta(ji,jj,jk) = ta(ji,jj,jk) * (1.-tsmsk(ji,jk)) + & 497 tsmsk(ji,jk) * ( ( 1. + z05cx - ztau ) & 498 * tsbnd(ji,jk,nib ,nitm) - 2.*z05cx & 499 * tsbnd(ji,jk,nibm,nit ) + ztau * tfos (ji,jk) ) & 500 / (1. - z05cx) 501 sa(ji,jj,jk) = sa(ji,jj,jk) * (1.-tsmsk(ji,jk)) + & 502 tsmsk(ji,jk) * ( ( 1. + z05cx - ztau ) & 503 * ssbnd(ji,jk,nib ,nitm) - 2.*z05cx & 504 * ssbnd(ji,jk,nibm,nit ) + ztau * sfos (ji,jk) ) & 505 / (1. - z05cx) 506 END DO 507 END DO 508 END DO 509 510 END IF 511 512 END SUBROUTINE obc_tra_south 513 87 END DO 88 ! 89 CALL lbc_lnk( ta, 'T', 1. ) ; CALL lbc_lnk( sa, 'T', 1. ) ! Boundary points should be updated 90 ! 91 IF( kt .eq. nit000 ) CLOSE( unit = 102 ) 92 ! 93 END SUBROUTINE obc_tra_frs 94 514 95 #else 515 !!---------------------------------------------------------------------- -----------516 !! D efault option Empty module517 !!---------------------------------------------------------------------- -----------96 !!---------------------------------------------------------------------- 97 !! Dummy module NO Unstruct Open Boundary Conditions 98 !!---------------------------------------------------------------------- 518 99 CONTAINS 519 SUBROUTINE obc_tra ! Empty routine 100 SUBROUTINE obc_tra(kt) ! Empty routine 101 WRITE(*,*) 'obc_tra: You should not have seen this print! error?', kt 520 102 END SUBROUTINE obc_tra 521 103 #endif 522 104 523 !!====================================================================== ===========105 !!====================================================================== 524 106 END MODULE obctra -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/OBC/obcvol.F90
r2528 r2797 1 1 MODULE obcvol 2 !!====================================================================== ===========2 !!====================================================================== 3 3 !! *** MODULE obcvol *** 4 !! Ocean dynamic : Volume constraint when OBC and Free surface are used 5 !!================================================================================= 6 #if defined key_obc && ! defined key_vvl 7 !!--------------------------------------------------------------------------------- 8 !! 'key_obc' and NOT open boundary conditions 9 !! 'key_vvl' constant volume free surface 10 !!--------------------------------------------------------------------------------- 11 !! * Modules used 12 USE oce ! ocean dynamics and tracers 13 USE dom_oce ! ocean space and time domain 14 USE sbc_oce ! ocean surface boundary conditions 15 USE phycst ! physical constants 16 USE obc_oce ! ocean open boundary conditions 17 USE lib_mpp ! for mppsum 18 USE in_out_manager ! I/O manager 19 20 IMPLICIT NONE 21 PRIVATE 22 23 !! * Accessibility 24 PUBLIC obc_vol ! routine called by dynspg_flt 25 26 !! * Substitutions 27 # include "domzgr_substitute.h90" 28 # include "obc_vectopt_loop_substitute.h90" 29 !!--------------------------------------------------------------------------------- 30 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 31 !! $Id$ 32 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 33 !!--------------------------------------------------------------------------------- 34 4 !! Ocean dynamic : Volume constraint when unstructured boundary 5 !! and Free surface are used 6 !!====================================================================== 7 !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code 8 !! - ! 2006-01 (J. Chanut) Bug correction 9 !! 3.0 ! 2008-04 (NEMO team) add in the reference version 10 !!---------------------------------------------------------------------- 11 #if defined key_obc && defined key_dynspg_flt 12 !!$ !!---------------------------------------------------------------------- 13 !!$ !! 'key_obc' AND unstructured open boundary conditions 14 !!$ !! 'key_dynspg_flt' filtered free surface 15 !!$ !!---------------------------------------------------------------------- 16 !!$ USE oce ! ocean dynamics and tracers 17 !!$ USE dom_oce ! ocean space and time domain 18 !!$ USE phycst ! physical constants 19 !!$ USE obc_oce ! ocean open boundary conditions 20 !!$ USE lib_mpp ! for mppsum 21 !!$ USE in_out_manager ! I/O manager 22 !!$ USE sbc_oce ! ocean surface boundary conditions 23 !!$ 24 !!$ IMPLICIT NONE 25 !!$ PRIVATE 26 !!$ 27 !!$ PUBLIC obc_vol ! routine called by dynspg_flt.h90 28 !!$ 29 !!$ !! * Substitutions 30 !!$# include "domzgr_substitute.h90" 31 !!$ !!---------------------------------------------------------------------- 32 !!$ !! NEMO/OPA 3.3 , NEMO Consortium (2010) 33 !!$ !! $Id$ 34 !!$ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 35 !!$ !!---------------------------------------------------------------------- 36 !!$CONTAINS 37 !!$ 38 !!$ SUBROUTINE obc_vol( kt ) 39 !!$ !!---------------------------------------------------------------------- 40 !!$ !! *** ROUTINE obcvol *** 41 !!$ !! 42 !!$ !! ** Purpose : This routine is called in dynspg_flt to control 43 !!$ !! the volume of the system. A correction velocity is calculated 44 !!$ !! to correct the total transport through the unstructured OBC. 45 !!$ !! The total depth used is constant (H0) to be consistent with the 46 !!$ !! linear free surface coded in OPA 8.2 47 !!$ !! 48 !!$ !! ** Method : The correction velocity (zubtpecor here) is defined calculating 49 !!$ !! the total transport through all open boundaries (trans_obc) minus 50 !!$ !! the cumulate E-P flux (z_cflxemp) divided by the total lateral 51 !!$ !! surface (obcsurftot) of the unstructured boundary. 52 !!$ !! zubtpecor = [trans_obc - z_cflxemp ]*(1./obcsurftot) 53 !!$ !! with z_cflxemp => sum of (Evaporation minus Precipitation) 54 !!$ !! over all the domain in m3/s at each time step. 55 !!$ !! z_cflxemp < 0 when precipitation dominate 56 !!$ !! z_cflxemp > 0 when evaporation dominate 57 !!$ !! 58 !!$ !! There are 2 options (user's desiderata): 59 !!$ !! 1/ The volume changes according to E-P, this is the default 60 !!$ !! option. In this case the cumulate E-P flux are setting to 61 !!$ !! zero (z_cflxemp=0) to calculate the correction velocity. So 62 !!$ !! it will only balance the flux through open boundaries. 63 !!$ !! (set nn_volctl to 0 in tne namelist for this option) 64 !!$ !! 2/ The volume is constant even with E-P flux. In this case 65 !!$ !! the correction velocity must balance both the flux 66 !!$ !! through open boundaries and the ones through the free 67 !!$ !! surface. 68 !!$ !! (set nn_volctl to 1 in tne namelist for this option) 69 !!$ !!---------------------------------------------------------------------- 70 !!$ INTEGER, INTENT( in ) :: kt ! ocean time-step index 71 !!$ !! 72 !!$ INTEGER :: ji, jj, jk, jb, jgrd 73 !!$ INTEGER :: ii, ij 74 !!$ REAL(wp) :: zubtpecor, z_cflxemp, ztranst 75 !!$ !!----------------------------------------------------------------------------- 76 !!$ 77 !!$ IF( ln_vol ) THEN 78 !!$ 79 !!$ IF( kt == nit000 ) THEN 80 !!$ IF(lwp) WRITE(numout,*) 81 !!$ IF(lwp) WRITE(numout,*)'obc_vol : Correction of velocities along unstructured OBC' 82 !!$ IF(lwp) WRITE(numout,*)'~~~~~~~' 83 !!$ END IF 84 !!$ 85 !!$ ! Calculate the cumulate surface Flux z_cflxemp (m3/s) over all the domain 86 !!$ ! ----------------------------------------------------------------------- 87 !!$ z_cflxemp = SUM ( ( emp(:,:)-rnf(:,:) ) * obctmask(:,:) * e1t(:,:) * e2t(:,:) ) / rau0 88 !!$ IF( lk_mpp ) CALL mpp_sum( z_cflxemp ) ! sum over the global domain 89 !!$ 90 !!$ ! Transport through the unstructured open boundary 91 !!$ ! ------------------------------------------------ 92 !!$ zubtpecor = 0.e0 93 !!$ jgrd = 2 ! cumulate u component contribution first 94 !!$ DO jb = 1, nblenrim(jgrd) 95 !!$ DO jk = 1, jpkm1 96 !!$ ii = nbi(jb,jgrd) 97 !!$ ij = nbj(jb,jgrd) 98 !!$ zubtpecor = zubtpecor + flagu(jb) * ua(ii,ij, jk) * e2u(ii,ij) * fse3u(ii,ij,jk) 99 !!$ END DO 100 !!$ END DO 101 !!$ jgrd = 3 ! then add v component contribution 102 !!$ DO jb = 1, nblenrim(jgrd) 103 !!$ DO jk = 1, jpkm1 104 !!$ ii = nbi(jb,jgrd) 105 !!$ ij = nbj(jb,jgrd) 106 !!$ zubtpecor = zubtpecor + flagv(jb) * va(ii,ij, jk) * e1v(ii,ij) * fse3v(ii,ij,jk) 107 !!$ END DO 108 !!$ END DO 109 !!$ IF( lk_mpp ) CALL mpp_sum( zubtpecor ) ! sum over the global domain 110 !!$ 111 !!$ ! The normal velocity correction 112 !!$ ! ------------------------------ 113 !!$ IF( nn_volctl==1 ) THEN ; zubtpecor = ( zubtpecor - z_cflxemp) / obcsurftot 114 !!$ ELSE ; zubtpecor = zubtpecor / obcsurftot 115 !!$ END IF 116 !!$ 117 !!$ ! Correction of the total velocity on the unstructured boundary to respect the mass flux conservation 118 !!$ ! ------------------------------------------------------------- 119 !!$ ztranst = 0.e0 120 !!$ jgrd = 2 ! correct u component 121 !!$ DO jb = 1, nblenrim(jgrd) 122 !!$ DO jk = 1, jpkm1 123 !!$ ii = nbi(jb,jgrd) 124 !!$ ij = nbj(jb,jgrd) 125 !!$ ua(ii,ij,jk) = ua(ii,ij,jk) - flagu(jb) * zubtpecor * umask(ii,ij,jk) 126 !!$ ztranst = ztranst + flagu(jb) * ua(ii,ij,jk) * e2u(ii,ij) * fse3u(ii,ij,jk) 127 !!$ END DO 128 !!$ END DO 129 !!$ jgrd = 3 ! correct v component 130 !!$ DO jb = 1, nblenrim(jgrd) 131 !!$ DO jk = 1, jpkm1 132 !!$ ii = nbi(jb,jgrd) 133 !!$ ij = nbj(jb,jgrd) 134 !!$ va(ii,ij,jk) = va(ii,ij,jk) -flagv(jb) * zubtpecor * vmask(ii,ij,jk) 135 !!$ ztranst = ztranst + flagv(jb) * va(ii,ij,jk) * e1v(ii,ij) * fse3v(ii,ij,jk) 136 !!$ END DO 137 !!$ END DO 138 !!$ IF( lk_mpp ) CALL mpp_sum( ztranst ) ! sum over the global domain 139 !!$ 140 !!$ ! Check the cumulated transport through unstructured OBC once barotropic velocities corrected 141 !!$ ! ------------------------------------------------------ 142 !!$ IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 143 !!$ IF(lwp) WRITE(numout,*) 144 !!$ IF(lwp) WRITE(numout,*)'obc_vol : time step :', kt 145 !!$ IF(lwp) WRITE(numout,*)'~~~~~~~ ' 146 !!$ IF(lwp) WRITE(numout,*)' cumulate flux EMP =', z_cflxemp , ' (m3/s)' 147 !!$ IF(lwp) WRITE(numout,*)' total lateral surface of OBC =', obcsurftot, '(m2)' 148 !!$ IF(lwp) WRITE(numout,*)' correction velocity zubtpecor =', zubtpecor , '(m/s)' 149 !!$ IF(lwp) WRITE(numout,*)' cumulated transport ztranst =', ztranst , '(m3/s)' 150 !!$ END IF 151 !!$ ! 152 !!$ END IF ! ln_vol 153 !!$ 154 !!$ END SUBROUTINE obc_vol 155 !!$ 156 !!$#else 157 !!---------------------------------------------------------------------- 158 !! Dummy module NO Unstruct Open Boundary Conditions 159 !!---------------------------------------------------------------------- 35 160 CONTAINS 36 37 SUBROUTINE obc_vol ( kt ) 38 !!------------------------------------------------------------------------------ 39 !! *** ROUTINE obcvol *** 40 !! 41 !! ** Purpose : 42 !! This routine is called in dynspg_flt to control 43 !! the volume of the system. A correction velocity is calculated 44 !! to correct the total transport through the OBC. 45 !! The total depth used is constant (H0) to be consistent with the 46 !! linear free surface coded in OPA 8.2 47 !! 48 !! ** Method : 49 !! The correction velocity (zubtpecor here) is defined calculating 50 !! the total transport through all open boundaries (trans_obc) minus 51 !! the cumulate E-P flux (zCflxemp) divided by the total lateral 52 !! surface (obcsurftot) of these OBC. 53 !! 54 !! zubtpecor = [trans_obc - zCflxemp ]*(1./obcsurftot) 55 !! 56 !! with zCflxemp => sum of (Evaporation minus Precipitation) 57 !! over all the domain in m3/s at each time step. 58 !! 59 !! zCflxemp < 0 when precipitation dominate 60 !! zCflxemp > 0 when evaporation dominate 61 !! 62 !! There are 2 options (user's desiderata): 63 !! 64 !! 1/ The volume changes according to E-P, this is the default 65 !! option. In this case the cumulate E-P flux are setting to 66 !! zero (zCflxemp=0) to calculate the correction velocity. So 67 !! it will only balance the flux through open boundaries. 68 !! (set volemp to 0 in tne namelist for this option) 69 !! 70 !! 2/ The volume is constant even with E-P flux. In this case 71 !! the correction velocity must balance both the flux 72 !! through open boundaries and the ones through the free 73 !! surface. 74 !! (set volemp to 1 in tne namelist for this option) 75 !! 76 !! History : 77 !! 8.5 ! 02-10 (C. Talandier, A-M. Treguier) Original code 78 !!---------------------------------------------------------------------------- 79 !! * Arguments 80 INTEGER, INTENT( in ) :: kt ! ocean time-step index 81 82 !! * Local declarations 83 INTEGER :: ji, jj, jk 84 REAL(wp) :: zubtpecor 85 REAL(wp) :: zCflxemp 86 REAL(wp) :: ztransw, ztranse, ztransn, ztranss, ztranst 87 !!----------------------------------------------------------------------------- 88 89 IF( kt == nit000 ) THEN 90 IF(lwp) WRITE(numout,*)' ' 91 IF(lwp) WRITE(numout,*)'obc_vol : Correction of velocities along OBC' 92 IF(lwp) WRITE(numout,*)'~~~~~~~' 93 IF(lwp) WRITE(numout,*)' ' 94 END IF 95 96 ! 1. Calculate the cumulate surface Flux zCflxemp (m3/s) over all the domain. 97 ! --------------------------------------------------------------------------- 98 99 zCflxemp = SUM ( ( emp(:,:)-rnf(:,:) )*obctmsk(:,:)* e1t(:,:) * e2t(:,:) / rau0 ) 100 101 IF( lk_mpp ) CALL mpp_sum( zCflxemp ) ! sum over the global domain 102 103 ! 2. Barotropic velocity for each open boundary 104 ! --------------------------------------------- 105 106 zubtpecor = 0.e0 107 108 ! ... East open boundary 109 IF( lp_obc_east ) THEN ! ... Total transport through the East OBC 110 DO ji = fs_nie0, fs_nie1 ! Vector opt. 111 DO jk = 1, jpkm1 112 DO jj = 1, jpj 113 zubtpecor = zubtpecor - ua(ji,jj,jk)*e2u(ji,jj)*fse3u(ji,jj,jk) * & 114 & uemsk(jj,jk)*MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 115 END DO 116 END DO 117 END DO 118 END IF 119 120 ! ... West open boundary 121 IF( lp_obc_west ) THEN ! ... Total transport through the West OBC 122 DO ji = fs_niw0, fs_niw1 ! Vector opt. 123 DO jk = 1, jpkm1 124 DO jj = 1, jpj 125 zubtpecor = zubtpecor + ua(ji,jj,jk)*e2u(ji,jj)*fse3u(ji,jj,jk) * & 126 & uwmsk(jj,jk) *MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 127 END DO 128 END DO 129 END DO 130 ENDIF 131 132 ! ... North open boundary 133 IF( lp_obc_north ) THEN ! ... Total transport through the North OBC 134 DO jj = fs_njn0, fs_njn1 ! Vector opt. 135 DO jk = 1, jpkm1 136 DO ji = 1, jpi 137 zubtpecor = zubtpecor - va(ji,jj,jk)*e1v(ji,jj)*fse3v(ji,jj,jk) * & 138 & vnmsk(ji,jk) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 139 END DO 140 END DO 141 END DO 142 ENDIF 143 144 ! ... South open boundary 145 IF( lp_obc_south ) THEN ! ... Total transport through the South OBC 146 DO jj = fs_njs0, fs_njs1 ! Vector opt. 147 DO jk = 1, jpkm1 148 DO ji = 1, jpi 149 zubtpecor = zubtpecor + va(ji,jj,jk)*e1v(ji,jj)*fse3v(ji,jj,jk) * & 150 & vsmsk(ji,jk) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 151 END DO 152 END DO 153 END DO 154 ENDIF 155 156 IF( lk_mpp ) CALL mpp_sum( zubtpecor ) ! sum over the global domain 157 158 159 ! 3. The normal velocity correction 160 ! --------------------------------- 161 IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 162 IF(lwp) WRITE(numout,*)' ' 163 IF(lwp) WRITE(numout,*)'obc_vol : time step :', kt 164 IF(lwp) WRITE(numout,*)'~~~~~~~ ' 165 IF(lwp) WRITE(numout,*)' cumulate flux EMP :', zCflxemp,' (m3/s)' 166 IF(lwp) WRITE(numout,*)' lateral transport :',zubtpecor,'(m3/s)' 167 IF(lwp) WRITE(numout,*)' net inflow :',zubtpecor-zCflxemp,'(m3/s)' 168 ENDIF 169 170 zubtpecor = (zubtpecor - zCflxemp*volemp)*(1./obcsurftot) 171 172 IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 173 IF(lwp) WRITE(numout,*)' total lateral surface of OBC :',obcsurftot,'(m2)' 174 IF(lwp) WRITE(numout,*)' correction velocity zubtpecor :',zubtpecor,'(m/s)' 175 IF(lwp) WRITE(numout,*)' ' 176 END IF 177 178 ! 4. Correction of the total velocity on each open 179 ! boundary to respect the mass flux conservation 180 ! ------------------------------------------------- 181 182 ztranse = 0.e0 ; ztransw = 0.e0 ; ztransn = 0.e0 ; ztranss = 0.e0 183 ztranst = 0.e0 ! total 184 185 IF( lp_obc_west ) THEN 186 ! ... correction of the west velocity 187 DO ji = fs_niw0, fs_niw1 ! Vector opt. 188 DO jk = 1, jpkm1 189 DO jj = 1, jpj 190 ua(ji,jj,jk) = ua(ji,jj,jk) - zubtpecor*uwmsk(jj,jk) 191 ztransw= ztransw + ua(ji,jj,jk)*fse3u(ji,jj,jk)*e2u(ji,jj)*uwmsk(jj,jk) * & 192 & MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 193 END DO 194 END DO 195 END DO 196 197 IF( lk_mpp ) CALL mpp_sum( ztransw ) ! sum over the global domain 198 199 IF( lwp .AND. MOD( kt, nwrite ) == 0) WRITE(numout,*)' West OB transport ztransw :', ztransw,'(m3/s)' 200 END IF 201 202 IF( lp_obc_east ) THEN 203 204 ! ... correction of the east velocity 205 DO ji = fs_nie0, fs_nie1 ! Vector opt. 206 DO jk = 1, jpkm1 207 DO jj = 1, jpj 208 ua(ji,jj,jk) = ua(ji,jj,jk) + zubtpecor*uemsk(jj,jk) 209 ztranse= ztranse + ua(ji,jj,jk)*fse3u(ji,jj,jk)*e2u(ji,jj)*uemsk(jj,jk) * & 210 & MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 211 END DO 212 END DO 213 END DO 214 215 IF( lk_mpp ) CALL mpp_sum( ztranse ) ! sum over the global domain 216 217 IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 218 IF(lwp) WRITE(numout,*)' East OB transport ztranse :', ztranse,'(m3/s)' 219 END IF 220 221 END IF 222 223 IF( lp_obc_north ) THEN 224 225 ! ... correction of the north velocity 226 DO jj = fs_njn0, fs_njn1 ! Vector opt. 227 DO jk = 1, jpkm1 228 DO ji = 1, jpi 229 va(ji,jj,jk) = va(ji,jj,jk) + zubtpecor*vnmsk(ji,jk) 230 ztransn= ztransn + va(ji,jj,jk)*fse3v(ji,jj,jk)*e1v(ji,jj)*vnmsk(ji,jk) * & 231 & MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 232 END DO 233 END DO 234 END DO 235 IF( lk_mpp ) CALL mpp_sum( ztransn ) ! sum over the global domain 236 237 IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 238 IF(lwp) WRITE(numout,*)' North OB transport ztransn :', ztransn,'(m3/s)' 239 END IF 240 241 END IF 242 243 IF( lp_obc_south ) THEN 244 245 ! ... correction of the south velocity 246 DO jj = fs_njs0, fs_njs1 ! Vector opt. 247 DO jk = 1, jpkm1 248 DO ji = 1, jpi 249 va(ji,jj,jk) = va(ji,jj,jk) - zubtpecor*vsmsk(ji,jk) 250 ztranss= ztranss + va(ji,jj,jk)*fse3v(ji,jj,jk)*e1v(ji,jj)*vsmsk(ji,jk) * & 251 & MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 252 END DO 253 END DO 254 END DO 255 IF( lk_mpp ) CALL mpp_sum( ztranss ) ! sum over the global domain 256 257 IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 258 IF(lwp) WRITE(numout,*)' South OB transport ztranss :', ztranss,'(m3/s)' 259 END IF 260 261 END IF 262 263 ! 5. Check the cumulate transport through OBC 264 ! once barotropic velocities corrected 265 ! ------------------------------------------- 266 267 268 IF( lwp .AND. MOD( kt, nwrite ) == 0) THEN 269 ztranst = ztransw - ztranse + ztranss - ztransn 270 IF(lwp) WRITE(numout,*)' ' 271 IF(lwp) WRITE(numout,*)' Cumulate transport ztranst =', ztranst,'(m3/s)' 272 IF(lwp) WRITE(numout,*)' Balance =', ztranst - zCflxemp ,'(m3/s)' 273 IF(lwp) WRITE(numout,*)' ' 274 END IF 275 276 END SUBROUTINE obc_vol 277 278 #else 279 !!--------------------------------------------------------------------------------- 280 !! Default option : Empty module 281 !!--------------------------------------------------------------------------------- 282 CONTAINS 283 SUBROUTINE obc_vol ! Empty routine 161 SUBROUTINE obc_vol( kt ) ! Empty routine 162 WRITE(*,*) 'obc_vol: You should not have seen this print! error?', kt 284 163 END SUBROUTINE obc_vol 285 164 #endif 286 165 287 !!====================================================================== ===========166 !!====================================================================== 288 167 END MODULE obcvol -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
r2777 r2797 56 56 LOGICAL :: rotn ! flag to indicate whether field has been rotated 57 57 END TYPE FLD 58 59 TYPE, PUBLIC :: MAP_POINTER !: Array of integer pointers to 1D arrays 60 INTEGER, POINTER :: ptr(:) 61 END TYPE MAP_POINTER 58 62 59 63 !$AGRIF_DO_NOT_TREAT … … 98 102 CONTAINS 99 103 100 SUBROUTINE fld_read( kt, kn_fsbc, sd )104 SUBROUTINE fld_read( kt, kn_fsbc, sd, map, jit, timeshift ) 101 105 !!--------------------------------------------------------------------- 102 106 !! *** ROUTINE fld_read *** … … 113 117 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) 114 118 TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables 119 TYPE(MAP_POINTER),INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping index 120 INTEGER , INTENT(in ), OPTIONAL :: jit ! subcycle timestep for timesplitting option 121 INTEGER , INTENT(in ), OPTIONAL :: timeshift ! provide fields at time other than "now" 115 122 !! 116 123 INTEGER :: imf ! size of the structure sd … … 127 134 !!--------------------------------------------------------------------- 128 135 ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar 129 isecsbc = nsec_year + nsec1jan000 + NINT(0.5 * REAL(kn_fsbc - 1,wp) * rdttra(1)) ! middle of sbc time step 136 IF( present(timeshift) ) THEN 137 isecsbc = nsec_year + nsec1jan000 + NINT(0.5 * REAL(kn_fsbc - 1,wp) * rdttra(1)) + timeshift * rdttra(1) ! middle of sbc time step 138 ELSE 139 isecsbc = nsec_year + nsec1jan000 + NINT(0.5 * REAL(kn_fsbc - 1,wp) * rdttra(1)) ! middle of sbc time step 140 ENDIF 130 141 imf = SIZE( sd ) 131 142 ! 132 143 IF( kt == nit000 ) THEN ! initialization 133 DO jf = 1, imf 134 CALL fld_init( kn_fsbc, sd(jf) ) ! read each before field (put them in after as they will be swapped) 135 END DO 144 IF( PRESENT(map) ) THEN 145 DO jf = 1, imf 146 CALL fld_init( kn_fsbc, sd(jf), map(jf)%ptr ) ! read each before field (put them in after as they will be swapped) 147 END DO 148 ELSE 149 DO jf = 1, imf 150 CALL fld_init( kn_fsbc, sd(jf) ) ! read each before field (put them in after as they will be swapped) 151 END DO 152 ENDIF 136 153 IF( lwp ) CALL wgt_print() ! control print 137 154 CALL fld_rot( kt, sd ) ! rotate vector fiels if needed … … 212 229 213 230 ! read after data 214 CALL fld_get( sd(jf) ) 231 IF( PRESENT(map) ) THEN 232 CALL fld_get( sd(jf), map(jf)%ptr ) 233 ELSE 234 CALL fld_get( sd(jf) ) 235 ENDIF 215 236 216 237 ENDIF … … 230 251 ! temporal interpolation weights 231 252 ztinta = REAL( isecsbc - sd(jf)%nrec_b(2), wp ) / REAL( sd(jf)%nrec_a(2) - sd(jf)%nrec_b(2), wp ) 253 IF( PRESENT(map) ) THEN 254 IF(lwp) WRITE(numout,*) '============================================' 255 IF(lwp) WRITE(numout,*) 'Output from fld_read(map) on timestep ',kt 256 IF(lwp) WRITE(numout,*) '============================================' 257 IF(lwp) WRITE(numout,*) 'sd(jf)%nrec_b(2), sd(jf)%nrec_a(2), isecsbc, ztinta, ztintb : ',sd(jf)%nrec_b(2),sd(jf)%nrec_a(2),isecsbc,ztinta,ztintb 258 ENDIF 232 259 ztintb = 1. - ztinta 233 260 !CDIR COLLAPSE … … 253 280 254 281 255 SUBROUTINE fld_init( kn_fsbc, sdjf )282 SUBROUTINE fld_init( kn_fsbc, sdjf, map ) 256 283 !!--------------------------------------------------------------------- 257 284 !! *** ROUTINE fld_init *** … … 262 289 INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) 263 290 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 291 INTEGER , INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping indices 264 292 !! 265 293 LOGICAL :: llprevyr ! are we reading previous year file? … … 364 392 365 393 ! read before data 366 CALL fld_get( sdjf ) ! read before values in after arrays(as we will swap it later) 394 IF( PRESENT(map) ) THEN 395 CALL fld_get( sdjf, map ) ! read before values in after arrays(as we will swap it later) 396 ELSE 397 CALL fld_get( sdjf ) ! read before values in after arrays(as we will swap it later) 398 ENDIF 367 399 368 400 clfmt = "('fld_init : time-interpolation for ', a, ' read previous record = ', i4, ' at time = ', f7.2, ' days')" … … 546 578 547 579 548 SUBROUTINE fld_get( sdjf )549 !!--------------------------------------------------------------------- 550 !! *** ROUTINE fld_ clopn***580 SUBROUTINE fld_get( sdjf, map ) 581 !!--------------------------------------------------------------------- 582 !! *** ROUTINE fld_get *** 551 583 !! 552 584 !! ** Purpose : read the data 553 585 !!---------------------------------------------------------------------- 554 586 TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables 587 INTEGER , INTENT(in), OPTIONAL, DIMENSION(:) :: map ! global-to-local mapping indices 555 588 !! 556 589 INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) … … 559 592 560 593 ipk = SIZE( sdjf%fnow, 3 ) 561 IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 594 595 IF( PRESENT(map) ) THEN 596 IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map ) 597 ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), map ) 598 ENDIF 599 ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 562 600 CALL wgt_list( sdjf, iw ) 563 601 IF( sdjf%ln_tint ) THEN ; CALL fld_interp( sdjf%num, sdjf%clvar, iw , ipk , sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) ) … … 581 619 END SUBROUTINE fld_get 582 620 621 SUBROUTINE fld_map( num, clvar, dta, nrec, map ) 622 !!--------------------------------------------------------------------- 623 !! *** ROUTINE fld_get *** 624 !! 625 !! ** Purpose : read global data from file and map onto local data 626 !! using a general mapping (for open boundaries) 627 !!---------------------------------------------------------------------- 628 USE obc_oce, ONLY: dta_global ! workspace to read in global data arrays 629 630 INTEGER , INTENT(in ) :: num ! stream number 631 CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name 632 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: dta ! output field on model grid 633 INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) 634 INTEGER, DIMENSION(:) , INTENT(in ) :: map ! global-to-local mapping indices 635 !! 636 INTEGER :: ipi ! length of boundary data on local process 637 INTEGER :: ipj ! length of dummy dimension ( = 1 ) 638 INTEGER :: ipk ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 639 INTEGER :: ilendta ! length of data in file 640 INTEGER :: idvar ! variable ID 641 INTEGER :: ib, ik ! loop counters 642 INTEGER :: ierr 643 !! 644 CHARACTER(len=80) :: zfile 645 !!--------------------------------------------------------------------- 646 647 ipi = SIZE( dta, 1 ) 648 ipj = 1 649 ipk = SIZE( dta, 3 ) 650 651 idvar = iom_varid( num, clvar ) 652 ilendta = iom_file(num)%dimsz(1,idvar) 653 IF(lwp) WRITE(numout,*) 'Dim size for ',TRIM(clvar),' is ', ilendta 654 655 CALL iom_get ( num, jpdom_unknown, clvar, dta_global(1:ilendta,1:ipj,1:ipk), nrec ) 656 ! 657 DO ib = 1, ipi 658 DO ik = 1, ipk 659 dta(ib,1,ik) = dta_global(map(ib),1,ik) 660 END DO 661 END DO 662 663 END SUBROUTINE fld_map 583 664 584 665 SUBROUTINE fld_rot( kt, sd ) 585 666 !!--------------------------------------------------------------------- 586 !! *** ROUTINE fld_ clopn***667 !! *** ROUTINE fld_rot *** 587 668 !! 588 669 !! ** Purpose : Vector fields may need to be rotated onto the local grid direction … … 672 753 ! 673 754 CALL iom_open( sdjf%clname, sdjf%num, ldstop = ldstop, ldiof = LEN(TRIM(sdjf%wgtname)) > 0 ) 674 755 ! 675 756 END SUBROUTINE fld_clopn 676 757 -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/SBC/sbcapr.F90
r2715 r2797 10 10 !! sbc_apr : read atmospheric pressure in netcdf files 11 11 !!---------------------------------------------------------------------- 12 USE bdy_par ! Unstructured boundary parameters13 12 USE obc_par ! open boundary condition parameters 14 13 USE dom_oce ! ocean space and time domain … … 30 29 ! !!* namsbc_apr namelist (Atmospheric PRessure) * 31 30 LOGICAL, PUBLIC :: ln_apr_obc = .FALSE. !: inverse barometer added to OBC ssh data 32 LOGICAL, PUBLIC :: ln_apr_bdy = .FALSE. !: inverse barometer added to BDY ssh data33 31 LOGICAL, PUBLIC :: ln_ref_apr = .FALSE. !: ref. pressure: global mean Patm (F) or a constant (F) 34 32 … … 115 113 ! 116 114 ! !* control check 117 IF( ln_apr_obc .OR. ln_apr_bdy) &118 CALL ctl_stop( 'sbc_apr: inverse barometer added to OBC or BDYssh data not yet implemented ' )115 IF( ln_apr_obc ) & 116 CALL ctl_stop( 'sbc_apr: inverse barometer added to OBC ssh data not yet implemented ' ) 119 117 IF( ln_apr_obc .AND. .NOT. lk_obc ) & 120 118 CALL ctl_stop( 'sbc_apr: add inverse barometer to OBC requires to use key_obc' ) 121 IF( ln_apr_bdy .AND. .NOT. lk_bdy ) & 122 CALL ctl_stop( 'sbc_apr: add inverse barometer to OBC requires to use key_bdy' ) 123 IF( ( ln_apr_obc .OR. ln_apr_bdy ) .AND. .NOT. lk_dynspg_ts ) & 119 IF( ( ln_apr_obc ) .AND. .NOT. lk_dynspg_ts ) & 124 120 CALL ctl_stop( 'sbc_apr: use inverse barometer ssh at open boundary ONLY possible with time-splitting' ) 125 IF( ( ln_apr_obc .OR. ln_apr_bdy) .AND. .NOT. ln_apr_dyn ) &121 IF( ( ln_apr_obc ) .AND. .NOT. ln_apr_dyn ) & 126 122 CALL ctl_stop( 'sbc_apr: use inverse barometer ssh at open boundary ONLY requires ln_apr_dyn=T' ) 127 123 ENDIF -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r2715 r2797 38 38 USE sbcfwb ! surface boundary condition: freshwater budget 39 39 USE closea ! closed sea 40 USE bdy_par ! unstructured open boundary data variables41 USE bdyice ! unstructured open boundary data (bdy_ice_frsroutine)40 USE obc_par ! for lk_obc 41 USE obcice_lim2 ! unstructured open boundary data (obc_ice_lim_2 routine) 42 42 43 43 USE prtctl ! Print control (prt_ctl routine) … … 253 253 ! 254 254 CASE( 2 ) ; CALL sbc_ice_lim_2( kt, nsbc ) ! LIM-2 ice model 255 IF( lk_ bdy ) CALL bdy_ice_frs ( kt ) ! BDYboundary condition255 IF( lk_obc ) CALL obc_ice_lim_2( kt ) ! OBC boundary condition 256 256 ! 257 257 CASE( 3 ) ; CALL sbc_ice_lim ( kt, nsbc ) ! LIM-3 ice model -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/SOL/solmat.F90
r2715 r2797 27 27 USE phycst ! physical constants 28 28 USE obc_oce ! ocean open boundary conditions 29 USE bdy_oce ! unstructured open boundary conditions30 29 USE lbclnk ! lateral boudary conditions 31 30 USE lib_mpp ! distributed memory computing … … 81 80 ENDIF 82 81 83 #if defined key_dynspg_flt && ! defined key_bdy82 #if defined key_dynspg_flt 84 83 # if ! defined key_obc 85 84 … … 99 98 END DO 100 99 END DO 100 101 101 # else 102 IF ( Agrif_Root() ) THEN 103 DO jj = 2, jpjm1 ! matrix of free surface elliptic system with open boundaries 104 DO ji = 2, jpim1 105 zcoef = z2dt * z2dt * grav * bmask(ji,jj) 106 ! ! south coefficient 107 IF( lp_obc_south .AND. ( jj == njs0p1 ) ) THEN 108 zcoefs = -zcoef * hv(ji,jj-1) * e1v(ji,jj-1)/e2v(ji,jj-1)*(1.-vsmsk(ji,1)) 109 ELSE 110 zcoefs = -zcoef * hv(ji,jj-1) * e1v(ji,jj-1)/e2v(ji,jj-1) 111 END IF 112 gcp(ji,jj,1) = zcoefs 113 ! 114 ! ! west coefficient 115 IF( lp_obc_west .AND. ( ji == niw0p1 ) ) THEN 116 zcoefw = -zcoef * hu(ji-1,jj) * e2u(ji-1,jj)/e1u(ji-1,jj)*(1.-uwmsk(jj,1)) 117 ELSE 118 zcoefw = -zcoef * hu(ji-1,jj) * e2u(ji-1,jj)/e1u(ji-1,jj) 119 END IF 120 gcp(ji,jj,2) = zcoefw 121 ! 122 ! ! east coefficient 123 IF( lp_obc_east .AND. ( ji == nie0 ) ) THEN 124 zcoefe = -zcoef * hu(ji,jj) * e2u(ji,jj)/e1u(ji,jj)*(1.-uemsk(jj,1)) 125 ELSE 126 zcoefe = -zcoef * hu(ji,jj) * e2u(ji,jj)/e1u(ji,jj) 127 END IF 128 gcp(ji,jj,3) = zcoefe 129 ! 130 ! ! north coefficient 131 IF( lp_obc_north .AND. ( jj == njn0 ) ) THEN 132 zcoefn = -zcoef * hv(ji,jj) * e1v(ji,jj)/e2v(ji,jj)*(1.-vnmsk(ji,1)) 133 ELSE 134 zcoefn = -zcoef * hv(ji,jj) * e1v(ji,jj)/e2v(ji,jj) 135 END IF 136 gcp(ji,jj,4) = zcoefn 137 ! 138 ! ! diagonal coefficient 139 gcdmat(ji,jj) = e1t(ji,jj)*e2t(ji,jj)*bmask(ji,jj) & 140 & - zcoefs -zcoefw -zcoefe -zcoefn 141 END DO 142 END DO 143 ELSE 144 DO jj = 2, jpjm1 ! matrix of free surface elliptic system 145 DO ji = 2, jpim1 146 zcoef = z2dt * z2dt * grav * bmask(ji,jj) 147 zcoefs = -zcoef * hv(ji ,jj-1) * e1v(ji ,jj-1) / e2v(ji ,jj-1) ! south coefficient 148 zcoefw = -zcoef * hu(ji-1,jj ) * e2u(ji-1,jj ) / e1u(ji-1,jj ) ! west coefficient 149 zcoefe = -zcoef * hu(ji ,jj ) * e2u(ji ,jj ) / e1u(ji ,jj ) ! east coefficient 150 zcoefn = -zcoef * hv(ji ,jj ) * e1v(ji ,jj ) / e2v(ji ,jj ) ! north coefficient 151 gcp(ji,jj,1) = zcoefs 152 gcp(ji,jj,2) = zcoefw 153 gcp(ji,jj,3) = zcoefe 154 gcp(ji,jj,4) = zcoefn 155 gcdmat(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * bmask(ji,jj) & ! diagonal coefficient 156 & - zcoefs -zcoefw -zcoefe -zcoefn 157 END DO 158 END DO 159 ENDIF 160 # endif 161 162 # elif defined key_dynspg_flt && defined key_bdy 163 164 ! defined gcdmat in the case of unstructured open boundaries 102 103 ! defined gcdmat in the case of open boundaries 165 104 DO jj = 2, jpjm1 166 105 DO ji = 2, jpim1 … … 169 108 ! south coefficient 170 109 zcoefs = -zcoef * hv(ji,jj-1) * e1v(ji,jj-1)/e2v(ji,jj-1) 171 zcoefs = zcoefs * bdyvmask(ji,jj-1)110 zcoefs = zcoefs * obcvmask(ji,jj-1) 172 111 gcp(ji,jj,1) = zcoefs 173 112 174 113 ! west coefficient 175 114 zcoefw = -zcoef * hu(ji-1,jj) * e2u(ji-1,jj)/e1u(ji-1,jj) 176 zcoefw = zcoefw * bdyumask(ji-1,jj)115 zcoefw = zcoefw * obcumask(ji-1,jj) 177 116 gcp(ji,jj,2) = zcoefw 178 117 179 118 ! east coefficient 180 119 zcoefe = -zcoef * hu(ji,jj) * e2u(ji,jj)/e1u(ji,jj) 181 zcoefe = zcoefe * bdyumask(ji,jj)120 zcoefe = zcoefe * obcumask(ji,jj) 182 121 gcp(ji,jj,3) = zcoefe 183 122 184 123 ! north coefficient 185 124 zcoefn = -zcoef * hv(ji,jj) * e1v(ji,jj)/e2v(ji,jj) 186 zcoefn = zcoefn * bdyvmask(ji,jj)125 zcoefn = zcoefn * obcvmask(ji,jj) 187 126 gcp(ji,jj,4) = zcoefn 188 127 … … 193 132 END DO 194 133 134 #endif 195 135 #endif 196 136 -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/SOL/solver.F90
r2715 r2797 23 23 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 24 24 USE solmat ! matrix of the solver 25 USE obc_oce ! Lateral open boundary condition26 25 USE in_out_manager ! I/O manager 27 26 USE lbclnk ! ocean lateral boundary conditions (or mpp link) -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r2715 r2797 36 36 USE obc_oce 37 37 USE obctra ! open boundary condition (obc_tra routine) 38 USE bdy_par ! Unstructured open boundary condition (bdy_tra_frs routine)39 USE bdytra ! Unstructured open boundary condition (bdy_tra_frs routine)40 38 USE in_out_manager ! I/O manager 41 39 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 43 41 USE traqsr ! penetrative solar radiation (needed for nksr) 44 42 USE traswp ! swap array 45 USE obc_oce46 43 #if defined key_agrif 47 44 USE agrif_opa_update … … 81 78 !! - Apply lateral boundary conditions on (ta,sa) 82 79 !! at the local domain boundaries through lbc_lnk call, 83 !! at the radiative open boundaries (lk_obc=T), 84 !! at the relaxed open boundaries (lk_bdy=T), and 80 !! at the one-way open boundaries (lk_obc=T), 85 81 !! at the AGRIF zoom boundaries (lk_agrif=T) 86 82 !! … … 111 107 CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 112 108 ! 113 #if defined key_obc || defined key_ bdy || defined key_agrif109 #if defined key_obc || defined key_agrif 114 110 CALL tra_unswap 115 111 #endif … … 118 114 IF( lk_obc ) CALL obc_tra( kt ) ! OBC open boundaries 119 115 #endif 120 #if defined key_bdy121 IF( lk_bdy ) CALL bdy_tra_frs( kt ) ! BDY open boundaries122 #endif123 116 #if defined key_agrif 124 117 CALL Agrif_tra ! AGRIF zoom boundaries 125 118 #endif 126 119 127 #if defined key_obc || defined key_ bdy || defined key_agrif120 #if defined key_obc || defined key_agrif 128 121 CALL tra_swap 129 122 #endif -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r2715 r2797 45 45 USE mppini ! shared/distributed memory setting (mpp_init routine) 46 46 USE domain ! domain initialization (dom_init routine) 47 USE obcini ! open boundary cond. initialization (obc_ini routine)48 USE bdyini ! unstructured open boundary cond. initialization (bdy_init routine)47 USE obcini ! open boundary cond. initialization (obc_init routine) 48 USE obcdta ! open boundary cond. initialization (obc_dta_init routine) 49 49 USE istate ! initial state setting (istate_init routine) 50 50 USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine) … … 294 294 IF( ln_ctl ) CALL prt_ctl_init ! Print control 295 295 296 IF( lk_obc ) CALL obc_init ! Open boundaries297 IF( lk_ bdy ) CALL bdy_init ! Unstructured open boundaries296 IF( lk_obc ) CALL obc_init ! Open boundaries initialisation 297 IF( lk_obc ) CALL obc_dta_init ! Open boundaries initialisation of external data arrays 298 298 299 299 CALL istate_init ! ocean initial state (Dynamics and tracers) -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/step.F90
r2715 r2797 98 98 CALL sbc ( kstp ) ! Sea Boundary Condition (including sea-ice) 99 99 IF( lk_obc ) CALL obc_dta( kstp ) ! update dynamic and tracer data at open boundaries 100 IF( lk_obc ) CALL obc_rad( kstp ) ! compute phase velocities at open boundaries101 IF( lk_bdy ) CALL bdy_dta_frs( kstp ) ! update dynamic and tracer data for FRS conditions (BDY)102 100 103 101 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 247 245 IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file 248 246 IF( lrst_oce ) CALL rst_write ( kstp ) ! write output ocean restart file 249 IF( lk_obc ) CALL obc_rst_write( kstp ) ! write open boundary restart file250 247 251 248 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -
branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/step_oce.F90
r2528 r2797 48 48 USE dynnxt ! time-stepping (dyn_nxt routine) 49 49 50 USE obc_par ! open boundary condition variables50 USE obc_par ! for lk_obc 51 51 USE obcdta ! open boundary condition data (obc_dta routine) 52 USE obcrst ! open boundary cond. restart (obc_rst routine)53 USE obcrad ! open boundary cond. radiation (obc_rad routine)54 55 USE bdy_par ! unstructured open boundary data variables56 USE bdydta ! unstructured open boundary data (bdy_dta routine)57 52 58 53 USE sshwzv ! vertical velocity and ssh (ssh_wzv routine)
Note: See TracChangeset
for help on using the changeset viewer.
