MODULE lbclnk_tam !!====================================================================== !! *** MODULE lbclnk_tam *** !! Ocean : adjoint of lateral boundary conditions !!===================================================================== #if defined key_mpp_mpi || defined key_mpp_shmem !!---------------------------------------------------------------------- !! 'key_mpp_mpi' OR MPI massively parallel processing library !! 'key_mpp_shmem' SHMEM massively parallel processing library !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- !! lbc_lnk_adj : generic interface for mpp_lnk_3d_adj and !! mpp_lnkadj_2d routines defined in lib_mpp_tam !! lbc_lnk_adj_e : generic interface for mpp_lnk_2d_e_adj !! routine defined in lib_mpp_tam !!---------------------------------------------------------------------- !! * Modules used USE lib_mpp_tam ! distributed memory computing library INTERFACE lbc_lnk_adj MODULE PROCEDURE mpp_lnk_3d_gather_adj, mpp_lnk_3d_adj, mpp_lnk_2d_adj END INTERFACE INTERFACE lbc_lnk_e_adj MODULE PROCEDURE mpp_lnk_2d_e_adj END INTERFACE PUBLIC lbc_lnk_adj ! ocean lateral boundary conditions PUBLIC lbc_lnk_e_adj ! ocean lateral boundary conditions !!---------------------------------------------------------------------- #else !!---------------------------------------------------------------------- !! Default option shared memory computing !!---------------------------------------------------------------------- !! lbc_lnk_adj : generic interface for lbc_lnkadj_3d and lbc_lnkadj_2d !! lbc_lnk_3d_adj : set the lateral boundary condition on a 3D variable !! on OPA ocean mesh !! lbc_lnk_2d_adj : set the lateral boundary condition on a 2D variable !! on OPA ocean mesh !!---------------------------------------------------------------------- !! * Modules used USE oce ! ocean dynamics and tracers USE dom_oce ! ocean space and time domain USE in_out_manager ! I/O manager IMPLICIT NONE PRIVATE INTERFACE lbc_lnk_adj MODULE PROCEDURE lbc_lnk_3d_gather_adj, lbc_lnk_3d_adj, lbc_lnk_2d_adj END INTERFACE INTERFACE lbc_lnk_e_adj MODULE PROCEDURE lbc_lnk_2d_adj END INTERFACE PUBLIC lbc_lnk_adj ! ocean/ice lateral boundary conditions PUBLIC lbc_lnk_e_adj ! ocean/ice lateral boundary conditions !!---------------------------------------------------------------------- CONTAINS SUBROUTINE lbc_lnk_3d_gather_adj( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) !!--------------------------------------------------------------------- !! *** ROUTINE lbc_lnkadj_3d_gather *** !! !! ** Purpose : Adjoint of set lateral boundary conditions (non mpp case) !! !! ** Method : !! !! History : !! ! 07-08 (K. Mogensen) Original code !!---------------------------------------------------------------------- !! * Arguments CHARACTER(len=1), INTENT( in ) :: & cd_type1, cd_type2 ! nature of pt3d grid-points ! ! = T , U , V , F or W gridpoints REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: & pt3d1, pt3d2 ! 3D array on which the boundary condition is applied REAL(wp), INTENT( in ) :: & psgn ! control of the sign change ! ! =-1 , the sign is changed if north fold boundary ! ! = 1 , no sign change ! ! = 0 , no sign change and > 0 required (use the inner ! ! row/column if closed boundary) !! * Local declarations INTEGER :: ji, jk INTEGER :: ijt, iju ! ! =============== DO jk = jpk, 1, -1 ! Horizontal slab ! ! =============== ! ! North-South boundaries ! ! ====================== SELECT CASE ( nperio ) CASE ( 2 ) ! * south symmetric SELECT CASE ( cd_type1 ) CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points pt3d1(:,jpj,jk) = 0.e0 pt3d1(:, 3 ,jk) = pt3d1(:,3,jk) + pt3d1(:,1,jk) pt3d1(:, 1 ,jk) = 0.e0 CASE ( 'V' , 'F' ) ! V-, F-points pt3d1(:,jpj,jk) = 0.e0 pt3d1(:, 2 ,jk) = pt3d1(:,2,jk) + psgn * pt3d1(:,1,jk) pt3d1(:, 1 ,jk) = 0.e0 END SELECT SELECT CASE ( cd_type2 ) CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points pt3d2(:,jpj,jk) = 0.e0 pt3d2(:, 3 ,jk) = pt3d2(:,3,jk) + pt3d2(:,1,jk) pt3d2(:, 1 ,jk) = 0.e0 CASE ( 'V' , 'F' ) ! V-, F-points pt3d2(:,jpj,jk) = 0.e0 pt3d2(:, 2 ,jk) = pt3d2(:,2,jk) + psgn * pt3d2(:,1,jk) pt3d2(:, 1 ,jk) = 0.e0 END SELECT CASE ( 3 , 4 ) ! * North fold T-point pivot SELECT CASE ( cd_type1 ) CASE ( 'T' , 'W' ) ! T-, W-point DO ji = jpi, jpi/2+1, -1 ijt = jpi-ji+2 pt3d1(ijt,jpjm1,jk) = pt3d1(ijt,jpjm1,jk) & & + psgn * pt3d1(ji ,jpjm1,jk) pt3d1(ji, jpjm1,jk) = 0.0e0 END DO DO ji = jpi, 2, -1 ijt = jpi-ji+2 pt3d1(ji,jpj-2,jk) = pt3d1(ijt,jpj-2,jk) & & + psgn * pt3d1(ji ,jpj ,jk) pt3d1(ji, jpj ,jk) = 0.e0 pt3d1(ji, 1 ,jk) = 0.e0 END DO CASE ( 'U' ) ! U-point DO ji = jpi-1, jpi/2, -1 iju = jpi-ji+1 pt3d1(iju,jpjm1,jk) = pt3d1(iju,jpjm1,jk) & & + psgn * pt3d1(ji ,jpjm1,jk) pt3d1(ji ,jpjm1,jk) = 0.0e0 END DO DO ji = jpi-1, 1, -1 iju = jpi-ji+1 pt3d1(iju,jpj-2,jk) = pt3d1(iju,jpj-2,jk) & & + psgn * pt3d1(ji ,jpj ,jk) pt3d1(ji ,jpj ,jk) = 0.e0 pt3d1(ji , 1 ,jk) = 0.e0 END DO CASE ( 'V' ) ! V-point DO ji = jpi, 2, -1 ijt = jpi-ji+2 pt3d1(ijt,jpj-3,jk) = pt3d1(ijt,jpj-3,jk) & & + psgn * pt3d1(ji ,jpj ,jk) pt3d1(ji ,jpj ,jk) = 0.e0 pt3d1(ijt,jpj-2,jk) = pt3d1(ijt,jpj-2,jk) & & + psgn * pt3d1(ji, jpj-1,jk) pt3d1(ji ,jpj-1,jk) = 0.e0 pt3d1(ji , 1 ,jk) = 0.e0 END DO CASE ( 'F' ) ! F-point DO ji = jpi-1, 1, -1 iju = jpi-ji+1 pt3d1(iju,jpj-3,jk) = pt3d1(iju,jpj-3,jk) & & + psgn * pt3d1(ji ,jpj ,jk) pt3d1(ji ,jpj ,jk) = 0.e0 pt3d1(iju,jpj-2,jk) = pt3d1(iju,jpj-2,jk) & & + psgn * pt3d1(ji ,jpj-1,jk) pt3d1(ji ,jpj-1,jk) = 0.e0 END DO END SELECT SELECT CASE ( cd_type2 ) CASE ( 'T' , 'W' ) ! T-, W-point DO ji = jpi, jpi/2+1, -1 ijt = jpi-ji+2 pt3d2(ijt,jpjm1,jk) = pt3d2(ijt,jpjm1,jk) & & + psgn * pt3d2(ji ,jpjm1,jk) pt3d2(ji ,jpjm1,jk) = 0.0e0 END DO DO ji = jpi, 2, -1 ijt = jpi-ji+2 pt3d2(ji,jpj-2,jk) = pt3d2(ijt,jpj-2,jk) & & + psgn * pt3d2(ji ,jpj ,jk) pt3d2(ji, jpj ,jk) = 0.e0 pt3d2(ji, 1 ,jk) = 0.e0 END DO CASE ( 'U' ) ! U-point DO ji = jpi-1, jpi/2, -1 iju = jpi-ji+1 pt3d2(iju,jpjm1,jk) = pt3d2(iju,jpjm1,jk) & & + psgn * pt3d2(ji ,jpjm1,jk) pt3d2(ji ,jpjm1,jk) = 0.0e0 END DO DO ji = jpi-1, 1, -1 iju = jpi-ji+1 pt3d2(iju,jpj-2,jk) = pt3d2(iju,jpj-2,jk) & & + psgn * pt3d2(ji ,jpj ,jk) pt3d2(ji ,jpj ,jk) = 0.e0 pt3d2(ji , 1 ,jk) = 0.e0 END DO CASE ( 'V' ) ! V-point DO ji = jpi, 2, -1 ijt = jpi-ji+2 pt3d2(ijt,jpj-3,jk) = pt3d2(ijt,jpj-3,jk) & & + psgn * pt3d2(ji ,jpj ,jk) pt3d2(ji ,jpj ,jk) = 0.e0 pt3d2(ijt,jpj-2,jk) = pt3d2(ijt,jpj-2,jk) & & + psgn * pt3d2(ji, jpj-1,jk) pt3d2(ji ,jpj-1,jk) = 0.e0 pt3d2(ji , 1 ,jk) = 0.e0 END DO CASE ( 'F' ) ! F-point DO ji = jpi-1, 1, -1 iju = jpi-ji+1 pt3d2(iju,jpj-3,jk) = pt3d2(iju,jpj-3,jk) & & + psgn * pt3d2(ji ,jpj ,jk) pt3d2(ji ,jpj ,jk) = 0.e0 pt3d2(iju,jpj-2,jk) = pt3d2(iju,jpj-2,jk) & & + psgn * pt3d2(ji ,jpj-1,jk) pt3d2(ji ,jpj-1,jk) = 0.e0 END DO END SELECT pt3d1(jpi,jpj,jk) = 0.e0 pt3d1( 1 ,jpj,jk) = 0.e0 pt3d2(jpi,jpj,jk) = 0.e0 pt3d2( 1 ,jpj,jk) = 0.e0 CASE ( 5 , 6 ) ! * North fold F-point pivot SELECT CASE ( cd_type1 ) CASE ( 'T' , 'W' ) ! T-, W-point DO ji = jpi, 1, -1 ijt = jpi-ji+1 pt3d1(ijt,jpj-1,jk) = pt3d1(ijt,jpj-1,jk) & & + psgn * pt3d1(ji ,jpj ,jk) pt3d1(ji ,jpj ,jk) = 0.e0 pt3d1(ji , 1 ,jk) = 0.e0 END DO CASE ( 'U' ) ! U-point DO ji = jpi-1, 1, -1 iju = jpi-ji pt3d1(iju,jpj-1,jk) = pt3d1(iju,jpj-1,jk) & & + psgn * pt3d1(ji ,jpj,jk) pt3d1(ji ,jpj ,jk) = 0.e0 pt3d1(ji , 1 ,jk) = 0.e0 END DO CASE ( 'V' ) ! V-point DO ji = jpi, jpi/2+1, -1 ijt = jpi-ji+1 pt3d1(ijt,jpjm1,jk) = pt3d1(ijt,jpjm1,jk) & & + psgn * pt3d1(ji ,jpjm1,jk) pt3d1(ji ,jpjm1,jk) = 0.e0 END DO DO ji = jpi, 1, -1 ijt = jpi-ji+1 pt3d1(ijt,jpj-2,jk) = pt3d1(ijt,jpj-2,jk)& & + psgn * pt3d1(ji ,jpj ,jk) pt3d1(ji ,jpj ,jk) = 0.e0 pt3d1(ji , 1 ,jk) = 0.e0 END DO CASE ( 'F' ) ! F-point DO ji = jpi-1, jpi/2+1, -1 iju = jpi-ji pt3d1(iju,jpjm1,jk) = pt3d1(iju,jpjm1,jk) & & + psgn * pt3d1(ji ,jpjm1,jk) pt3d1(ji ,jpjm1,jk) = 0.e0 END DO DO ji = jpi-1, 1, -1 iju = jpi-ji pt3d1(iju,jpj-2,jk) = pt3d1(iju,jpj-2,jk) & & + psgn * pt3d1(ji ,jpj ,jk) pt3d1(ji ,jpj ,jk) = 0.e0 END DO END SELECT SELECT CASE ( cd_type2 ) CASE ( 'T' , 'W' ) ! T-, W-point DO ji = jpi, 1, -1 ijt = jpi-ji+1 pt3d2(ijt,jpj-1,jk) = pt3d2(ijt,jpj-1,jk) & & + psgn * pt3d2(ji ,jpj ,jk) pt3d2(ji ,jpj ,jk) = 0.e0 pt3d2(ji , 1 ,jk) = 0.e0 END DO CASE ( 'U' ) ! U-point DO ji = jpi-1, 1, -1 iju = jpi-ji pt3d2(iju,jpj-1,jk) = pt3d2(iju,jpj-1,jk) & & + psgn * pt3d2(ji ,jpj,jk) pt3d2(ji ,jpj ,jk) = 0.e0 pt3d2(ji , 1 ,jk) = 0.e0 END DO CASE ( 'V' ) ! V-point DO ji = jpi, jpi/2+1, -1 ijt = jpi-ji+1 pt3d2(ijt,jpjm1,jk) = pt3d2(ijt,jpjm1,jk) & & + psgn * pt3d2(ji ,jpjm1,jk) pt3d2(ji ,jpjm1,jk) = 0.e0 END DO DO ji = jpi, 1, -1 ijt = jpi-ji+1 pt3d2(ijt,jpj-2,jk) = pt3d2(ijt,jpj-2,jk)& & + psgn * pt3d2(ji ,jpj ,jk) pt3d2(ji ,jpj ,jk) = 0.e0 pt3d2(ji , 1 ,jk) = 0.e0 END DO CASE ( 'F' ) ! F-point DO ji = jpi-1, jpi/2+1, -1 iju = jpi-ji pt3d2(iju,jpjm1,jk) = pt3d2(iju,jpjm1,jk) & & + psgn * pt3d2(ji ,jpjm1,jk) pt3d2(ji ,jpjm1,jk) = 0.e0 END DO DO ji = jpi-1, 1, -1 iju = jpi-ji pt3d2(iju,jpj-2,jk) = pt3d2(iju,jpj-2,jk) & & + psgn * pt3d2(ji ,jpj ,jk) pt3d2(ji ,jpj ,jk) = 0.e0 END DO END SELECT pt3d1(jpi,jpj,jk) = 0.e0 pt3d1( 1 ,jpj,jk) = 0.e0 pt3d2(jpi,jpj,jk) = 0.e0 pt3d2( 1 ,jpj,jk) = 0.e0 CASE DEFAULT ! * closed SELECT CASE ( cd_type1 ) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points pt3d1(:,jpj,jk) = 0.e0 pt3d1(:, 1 ,jk) = 0.e0 CASE ( 'F' ) ! F-point pt3d1(:,jpj,jk) = 0.e0 END SELECT SELECT CASE ( cd_type2 ) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points pt3d2(:,jpj,jk) = 0.e0 pt3d2(:, 1 ,jk) = 0.e0 CASE ( 'F' ) ! F-point pt3d2(:,jpj,jk) = 0.e0 END SELECT END SELECT ! ! East-West boundaries ! ! ==================== SELECT CASE ( nperio ) CASE ( 1 , 4 , 6 ) ! * cyclic east-west ! all points pt3d1( 2 ,:,jk) = pt3d1( 2 ,:,jk) & & + pt3d1( jpi ,:,jk) pt3d1( jpi ,:,jk) = 0.0e0 pt3d1(jpim1,:,jk) = pt3d1(jpim1,:,jk) & & + pt3d1( 1 ,:,jk) pt3d1( 1 ,:,jk) = 0.0e0 pt3d2( 2 ,:,jk) = pt3d2( 2 ,:,jk) & & + pt3d2( jpi ,:,jk) pt3d2( jpi ,:,jk) = 0.0e0 pt3d2(jpim1,:,jk) = pt3d2(jpim1,:,jk) & & + pt3d2( 1 ,:,jk) pt3d2( 1 ,:,jk) = 0.0e0 CASE DEFAULT ! * closed SELECT CASE ( cd_type1 ) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points pt3d1(jpi,:,jk) = 0.e0 pt3d1( 1 ,:,jk) = 0.e0 CASE ( 'F' ) ! F-point pt3d1(jpi,:,jk) = 0.e0 END SELECT SELECT CASE ( cd_type2 ) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points pt3d2(jpi,:,jk) = 0.e0 pt3d2( 1 ,:,jk) = 0.e0 CASE ( 'F' ) ! F-point pt3d2(jpi,:,jk) = 0.e0 END SELECT END SELECT ! ! =============== END DO ! End of slab ! ! =============== END SUBROUTINE lbc_lnk_3d_gather_adj SUBROUTINE lbc_lnk_3d_adj( pt3d, cd_type, psgn, cd_mpp ) !!--------------------------------------------------------------------- !! *** ROUTINE lbc_lnkadj_3d *** !! !! ** Purpose : Adjoint of set lateral boundary conditions (non mpp case) !! !! ** Method : !! !! History : !! ! 07-08 (K. Mogensen) Original code !!---------------------------------------------------------------------- !! * Arguments CHARACTER(len=1), INTENT( in ) :: & cd_type ! nature of pt3d grid-points ! ! = T , U , V , F or W gridpoints REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: & pt3d ! 3D array on which the boundary condition is applied REAL(wp), INTENT( in ) :: & psgn ! control of the sign change ! ! =-1 , the sign is changed if north fold boundary ! ! = 1 , no sign change ! ! = 0 , no sign change and > 0 required (use the inner ! ! row/column if closed boundary) CHARACTER(len=3), INTENT( in ), OPTIONAL :: & cd_mpp ! fill the overlap area only (here do nothing) !! * Local declarations INTEGER :: ji, jk INTEGER :: ijt, iju IF (PRESENT(cd_mpp)) THEN ! only fill the overlap area and extra allows ! this is in mpp case. In this module, just do nothing ELSE ! ! =============== DO jk = jpk, 1, -1 ! Horizontal slab ! ! =============== ! ! North-South boundaries ! ! ====================== SELECT CASE ( nperio ) CASE ( 2 ) ! * south symmetric SELECT CASE ( cd_type ) CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points pt3d(:,jpj,jk) = 0.e0 pt3d(:, 3 ,jk) = pt3d(:,3,jk) + pt3d(:,1,jk) pt3d(:, 1 ,jk) = 0.e0 CASE ( 'V' , 'F' ) ! V-, F-points pt3d(:,jpj,jk) = 0.e0 pt3d(:, 2 ,jk) = pt3d(:,2,jk) + psgn * pt3d(:,1,jk) pt3d(:, 1 ,jk) = 0.e0 END SELECT CASE ( 3 , 4 ) ! * North fold T-point pivot SELECT CASE ( cd_type ) CASE ( 'T' , 'W' ) ! T-, W-point DO ji = jpi, jpi/2+1, -1 ijt = jpi-ji+2 pt3d(ijt,jpjm1,jk) = pt3d(ijt,jpjm1,jk) & & + psgn * pt3d(ji ,jpjm1,jk) pt3d(ji,jpjm1,jk) = 0.0e0 END DO DO ji = jpi, 2, -1 ijt = jpi-ji+2 pt3d(ijt,jpj-2,jk) = pt3d(ijt,jpj-2,jk) & & + psgn * pt3d(ji ,jpj ,jk) pt3d(ji, jpj ,jk) = 0.e0 pt3d(ji, 1 ,jk) = 0.e0 END DO CASE ( 'U' ) ! U-point DO ji = jpi-1, jpi/2, -1 iju = jpi-ji+1 pt3d(iju,jpjm1,jk) = pt3d(iju,jpjm1,jk) & & + psgn * pt3d(ji ,jpjm1,jk) pt3d(ji ,jpjm1,jk) = 0.0e0 END DO DO ji = jpi-1, 1, -1 iju = jpi-ji+1 pt3d(iju,jpj-2,jk) = pt3d(iju,jpj-2,jk) & & + psgn * pt3d(ji ,jpj ,jk) pt3d(ji ,jpj ,jk) = 0.e0 pt3d(ji , 1 ,jk) = 0.e0 END DO CASE ( 'V' ) ! V-point DO ji = jpi, 2, -1 ijt = jpi-ji+2 pt3d(ijt,jpj-3,jk) = pt3d(ijt,jpj-3,jk) & & + psgn * pt3d(ji ,jpj ,jk) pt3d(ji ,jpj ,jk) = 0.e0 pt3d(ijt,jpj-2,jk) = pt3d(ijt,jpj-2,jk) & & + psgn * pt3d(ji, jpj-1,jk) pt3d(ji ,jpj-1,jk) = 0.e0 pt3d(ji , 1 ,jk) = 0.e0 END DO CASE ( 'F' ) ! F-point DO ji = jpi-1, 1, -1 iju = jpi-ji+1 pt3d(iju,jpj-3,jk) = pt3d(iju,jpj-3,jk) & & + psgn * pt3d(ji ,jpj ,jk) pt3d(ji ,jpj ,jk) = 0.e0 pt3d(iju,jpj-2,jk) = pt3d(iju,jpj-2,jk) & & + psgn * pt3d(ji ,jpj-1,jk) pt3d(ji ,jpj-1,jk) = 0.e0 END DO END SELECT pt3d(jpi,jpj,jk) = 0.e0 pt3d( 1 ,jpj,jk) = 0.e0 CASE ( 5 , 6 ) ! * North fold F-point pivot SELECT CASE ( cd_type ) CASE ( 'T' , 'W' ) ! T-, W-point DO ji = jpi, 1, -1 ijt = jpi-ji+1 pt3d(ijt,jpj-1,jk) = pt3d(ijt,jpj-1,jk) & & + psgn * pt3d(ji ,jpj ,jk) pt3d(ji ,jpj ,jk) = 0.e0 pt3d(ji , 1 ,jk) = 0.e0 END DO CASE ( 'U' ) ! U-point DO ji = jpi-1, 1, -1 iju = jpi-ji pt3d(iju,jpj-1,jk) = pt3d(iju,jpj-1,jk) & & + psgn * pt3d(ji ,jpj,jk) pt3d(ji ,jpj ,jk) = 0.e0 pt3d(ji , 1 ,jk) = 0.e0 END DO CASE ( 'V' ) ! V-point DO ji = jpi, jpi/2+1, -1 ijt = jpi-ji+1 pt3d(ijt,jpjm1,jk) = pt3d(ijt,jpjm1,jk) & & + psgn * pt3d(ji ,jpjm1,jk) pt3d(ji ,jpjm1,jk) = 0.e0 END DO DO ji = jpi, 1, -1 ijt = jpi-ji+1 pt3d(ijt,jpj-2,jk) = pt3d(ijt,jpj-2,jk)& & + psgn * pt3d(ji ,jpj ,jk) pt3d(ji ,jpj ,jk) = 0.e0 pt3d(ji , 1 ,jk) = 0.e0 END DO CASE ( 'F' ) ! F-point DO ji = jpi-1, jpi/2+1, -1 iju = jpi-ji pt3d(iju,jpjm1,jk) = pt3d(iju,jpjm1,jk) & & + psgn * pt3d(ji ,jpjm1,jk) pt3d(ji ,jpjm1,jk) = 0.e0 END DO DO ji = jpi-1, 1, -1 iju = jpi-ji pt3d(iju,jpj-2,jk) = pt3d(iju,jpj-2,jk) & & + psgn * pt3d(ji ,jpj ,jk) pt3d(ji ,jpj ,jk) = 0.e0 END DO END SELECT pt3d(jpi,jpj,jk) = 0.e0 pt3d( 1 ,jpj,jk) = 0.e0 CASE DEFAULT ! * closed SELECT CASE ( cd_type ) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points pt3d(:,jpj,jk) = 0.e0 pt3d(:, 1 ,jk) = 0.e0 CASE ( 'F' ) ! F-point pt3d(:,jpj,jk) = 0.e0 END SELECT END SELECT ! ! East-West boundaries ! ! ==================== SELECT CASE ( nperio ) CASE ( 1 , 4 , 6 ) ! * cyclic east-west ! all points pt3d( 2 ,:,jk) = pt3d( 2 ,:,jk) & & + pt3d( jpi ,:,jk) pt3d( jpi ,:,jk) = 0.0e0 pt3d(jpim1,:,jk) = pt3d(jpim1,:,jk) & & + pt3d( 1 ,:,jk) pt3d( 1 ,:,jk) = 0.0e0 CASE DEFAULT ! * closed SELECT CASE ( cd_type ) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points pt3d(jpi,:,jk) = 0.e0 pt3d( 1 ,:,jk) = 0.e0 CASE ( 'F' ) ! F-point pt3d(jpi,:,jk) = 0.e0 END SELECT END SELECT ! ! =============== END DO ! End of slab ! ! =============== ENDIF END SUBROUTINE lbc_lnk_3d_adj SUBROUTINE lbc_lnk_2d_adj( pt2d, cd_type, psgn, cd_mpp ) !!--------------------------------------------------------------------- !! *** ROUTINE lbc_lnkadj_2d *** !! !! ** Purpose : Adjoint of set lateral boundary conditions (non mpp case) !! !! ** Method : !! !! History : !! ! 07-08 (K. Mogensen) Original code !!---------------------------------------------------------------------- !! * Arguments CHARACTER(len=1), INTENT( in ) :: & cd_type ! nature of pt2d grid-point ! ! = T , U , V , F or W gridpoints ! ! = I sea-ice U-V gridpoint (= F ocean grid point with indice shift) REAL(wp), INTENT( in ) :: & psgn ! control of the sign change ! ! =-1 , the sign is modified following the type of b.c. used ! ! = 1 , no sign change REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: & pt2d ! 2D array on which the boundary condition is applied CHARACTER(len=3), INTENT( in ), OPTIONAL :: & cd_mpp ! fill the overlap area only (here do nothing) !! * Local declarations INTEGER :: ji INTEGER :: ijt, iju IF (PRESENT(cd_mpp)) THEN ! only fill the overlap area and extra allows ! this is in mpp case. In this module, just do nothing ELSE ! ! North-South boundaries ! ! ====================== SELECT CASE ( nperio ) CASE ( 2 ) ! * south symmetric SELECT CASE ( cd_type ) CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points pt2d(:,jpj) = 0.e0 pt2d(:, 3 ) = pt2d(:,3) + pt2d(:,1) pt2d(:, 1 ) = 0.e0 CASE ( 'V' , 'F' ) ! V-, F-points pt2d(:,jpj) = 0.e0 pt2d(:, 2 ) = pt2d(:,2) + psgn * pt2d(:,1) pt2d(:, 1 ) = 0.e0 END SELECT CASE ( 3 , 4 ) ! * North fold T-point pivot SELECT CASE ( cd_type ) CASE ( 'T' , 'W' ) ! T-, W-point DO ji = jpi, jpi/2+1, -1 ijt = jpi-ji+2 pt2d(ijt,jpjm1) = pt2d(ijt,jpjm1) & & + psgn * pt2d(ji ,jpjm1) pt2d(ji,jpjm1) = 0.0e0 END DO DO ji = jpi, 2, -1 ijt = jpi-ji+2 pt2d(ijt,jpj-2) = pt2d(ijt,jpj-2) & & + psgn * pt2d(ji ,jpj ) pt2d(ji, jpj ) = 0.e0 pt2d(ji, 1 ) = 0.e0 END DO CASE ( 'U' ) ! U-point DO ji = jpi-1, jpi/2, -1 iju = jpi-ji+1 pt2d(iju,jpjm1) = pt2d(iju,jpjm1) & & + psgn * pt2d(ji ,jpjm1) pt2d(ji ,jpjm1) = 0.0e0 END DO DO ji = jpi-1, 1, -1 iju = jpi-ji+1 pt2d(iju,jpj-2) = pt2d(iju,jpj-2) & & + psgn * pt2d(ji ,jpj ) pt2d(ji ,jpj ) = 0.e0 pt2d(ji , 1 ) = 0.e0 END DO CASE ( 'V' ) ! V-point DO ji = jpi, 2, -1 ijt = jpi-ji+2 pt2d(ijt,jpj-3) = pt2d(ijt,jpj-3) & & + psgn * pt2d(ji ,jpj ) pt2d(ji ,jpj ) = 0.e0 pt2d(ijt,jpj-2) = pt2d(ijt,jpj-2) & & + psgn * pt2d(ji, jpj-1) pt2d(ji ,jpj-1) = 0.e0 pt2d(ji , 1 ) = 0.e0 END DO CASE ( 'F' ) ! F-point DO ji = jpi-1, 1, -1 iju = jpi-ji+1 pt2d(iju,jpj-3) = pt2d(iju,jpj-3) & & + psgn * pt2d(ji ,jpj ) pt2d(ji ,jpj ) = 0.e0 pt2d(iju,jpj-2) = pt2d(iju,jpj-2) & & + psgn * pt2d(ji ,jpj-1) pt2d(ji ,jpj-1) = 0.e0 END DO END SELECT pt2d(jpi,jpj) = 0.e0 pt2d( 1 ,jpj) = 0.e0 pt2d( 1 , 1 ) = 0.e0 ! Is this a bug? CASE ( 5 , 6 ) ! * North fold F-point pivot SELECT CASE ( cd_type ) CASE ( 'T' , 'W' ) ! T-, W-point DO ji = jpi, 1, -1 ijt = jpi-ji+1 pt2d(ijt,jpj-1) = pt2d(ijt,jpj-1) & & + psgn * pt2d(ji ,jpj ) pt2d(ji ,jpj ) = 0.e0 pt2d(ji , 1 ) = 0.e0 END DO CASE ( 'U' ) ! U-point DO ji = jpi-1, 1, -1 iju = jpi-ji pt2d(iju,jpj-1) = pt2d(iju,jpj-1) & & + psgn * pt2d(ji ,jpj ) pt2d(ji ,jpj ) = 0.e0 pt2d(ji , 1 ) = 0.e0 END DO CASE ( 'V' ) ! V-point DO ji = jpi, jpi/2+1, -1 ijt = jpi-ji+1 pt2d(ijt,jpjm1) = pt2d(ijt,jpjm1) & & + psgn * pt2d(ji ,jpjm1) pt2d(ji ,jpjm1) = 0.e0 END DO DO ji = jpi, 1, -1 ijt = jpi-ji+1 pt2d(ijt,jpj-2) = pt2d(ijt,jpj-2) & & + psgn * pt2d(ji ,jpj ) pt2d(ji ,jpj ) = 0.e0 pt2d(ji , 1 ) = 0.e0 END DO CASE ( 'F' ) ! F-point DO ji = jpi-1, jpi/2+1, -1 iju = jpi-ji pt2d(iju,jpjm1) = pt2d(iju,jpjm1) & & + psgn * pt2d(ji ,jpjm1) pt2d(ji ,jpjm1) = 0.e0 END DO DO ji = jpi-1, 1, -1 iju = jpi-ji pt2d(iju,jpj-2) = pt2d(iju,jpj-2) & & + psgn * pt2d(ji ,jpj ) pt2d(ji ,jpj ) = 0.e0 END DO END SELECT pt2d(jpi,jpj) = 0.e0 pt2d( 1 ,jpj) = 0.e0 pt2d( 1 , 1 ) = 0.e0 ! Is this a bug? CASE DEFAULT ! * closed SELECT CASE ( cd_type ) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points pt2d(:,jpj) = 0.e0 pt2d(:, 1 ) = 0.e0 CASE ( 'F' ) ! F-point pt2d(:,jpj) = 0.e0 END SELECT END SELECT ! ! East-West boundaries ! ! ==================== SELECT CASE ( nperio ) CASE ( 1 , 4 , 6 ) ! * cyclic east-west ! all points pt2d( 2 ,:) = pt2d( 2 ,:) & & + pt2d( jpi ,:) pt2d( jpi ,:) = 0.0e0 pt2d(jpim1,:) = pt2d(jpim1,:) & & + pt2d( 1 ,:) pt2d( 1 ,:) = 0.0e0 CASE DEFAULT ! * closed SELECT CASE ( cd_type ) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points pt2d(jpi,:) = 0.e0 pt2d( 1 ,:) = 0.e0 CASE ( 'F' ) ! F-point pt2d(jpi,:) = 0.e0 END SELECT END SELECT ENDIF END SUBROUTINE lbc_lnk_2d_adj #endif END MODULE lbclnk_tam