source: branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/CRS/crslbclnk.F90 @ 5600

Last change on this file since 5600 was 5600, checked in by andrewryan, 5 years ago

merged in latest version of trunk alongside changes to SAO_SRC to be compatible with latest OBS

  • Property svn:keywords set to Id
File size: 6.1 KB
Line 
1MODULE crslbclnk
2
3   !!======================================================================
4   !!                       ***  MODULE  crslbclnk  ***
5   !!               A temporary solution for lbclnk for coarsened grid.
6   !! Ocean        : lateral boundary conditions for grid coarsening
7   !!=====================================================================
8   !! History :   ! 2012-06  (J. Simeon, G. Madec, C. Ethe, C. Calone)     Original code
9
10   USE dom_oce
11   USE crs
12   USE lbclnk
13   USE par_kind, ONLY: wp
14   USE in_out_manager
15
16   
17   
18   INTERFACE crs_lbc_lnk
19      MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_3d_gather, crs_lbc_lnk_2d
20   END INTERFACE
21   
22   PUBLIC crs_lbc_lnk
23   
24   !! $Id$
25CONTAINS
26
27   SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, cd_mpp, pval )
28      !!---------------------------------------------------------------------
29      !!                  ***  SUBROUTINE crs_lbc_lnk  ***
30      !!
31      !! ** Purpose :   set lateral boundary conditions for coarsened grid
32      !!
33      !! ** Method  :   Swap domain indices from full to coarse domain
34      !!                before arguments are passed directly to lbc_lnk.
35      !!                Upon exiting, switch back to full domain indices.
36      !!----------------------------------------------------------------------
37      !! Arguments
38      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type1 ! grid type
39      REAL(wp)                        , INTENT(in   )           ::   psgn     ! control of the sign
40
41      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout)   ::   pt3d1 ! 3D array on which the lbc is applied
42      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval     ! valeur sur les halo
43      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
44     
45      !! local vairables
46      LOGICAL                                                   ::   ll_grid_crs
47      REAL(wp)                                                  ::   zval     ! valeur sur les halo
48
49      !!----------------------------------------------------------------------
50     
51      ll_grid_crs = ( jpi == jpi_crs )
52     
53      IF( PRESENT(pval) ) THEN  ;  zval = pval
54      ELSE                      ;  zval = 0.0
55      ENDIF
56     
57      IF( .NOT. ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain
58
59      IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt3d1, cd_type1, psgn, cd_mpp, pval=zval  )
60      ELSE                         ; CALL lbc_lnk( pt3d1, cd_type1, psgn, pval=zval  )
61      ENDIF
62
63      IF( .NOT. ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain
64
65   END SUBROUTINE crs_lbc_lnk_3d
66   
67   SUBROUTINE crs_lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )
68      !!---------------------------------------------------------------------
69      !!                  ***  SUBROUTINE crs_lbc_lnk  ***
70      !!
71      !! ** Purpose :   set lateral boundary conditions for coarsened grid
72      !!
73      !! ** Method  :   Swap domain indices from full to coarse domain
74      !!                before arguments are passed directly to lbc_lnk.
75      !!                Upon exiting, switch back to full domain indices.
76      !!----------------------------------------------------------------------
77      !! Arguments
78      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type1,cd_type2 ! grid type
79      REAL(wp)                        , INTENT(in   )           ::   psgn     ! control of the sign
80
81      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout)   ::   pt3d1,pt3d2 ! 3D array on which the lbc is applied
82     
83      !! local vairables
84      LOGICAL                                                   ::   ll_grid_crs
85      !!----------------------------------------------------------------------
86     
87      ll_grid_crs = ( jpi == jpi_crs )
88     
89      IF( .NOT. ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain
90
91      CALL lbc_lnk( pt3d1, cd_type1, pt3d2, cd_type2, psgn  )
92
93      IF( .NOT. ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain
94
95   END SUBROUTINE crs_lbc_lnk_3d_gather
96
97   
98   
99   SUBROUTINE crs_lbc_lnk_2d(pt2d, cd_type, psgn, cd_mpp, pval)
100      !!---------------------------------------------------------------------
101      !!                  ***  SUBROUTINE crs_lbc_lnk  ***
102      !!
103      !! ** Purpose :   set lateral boundary conditions for coarsened grid
104      !!
105      !! ** Method  :   Swap domain indices from full to coarse domain
106      !!                before arguments are passed directly to lbc_lnk.
107      !!                Upon exiting, switch back to full domain indices.
108      !!----------------------------------------------------------------------
109      !! Arguments
110      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type  ! grid type
111      REAL(wp)                        , INTENT(in   )           ::   psgn     ! control of the sign
112
113      REAL(wp), DIMENSION(jpi_crs,jpj_crs),     INTENT(inout)   ::   pt2d     ! 2D array on which the lbc is applied
114      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval     ! valeur sur les halo
115      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp   ! MPP only (here do nothing)
116      !! local variables
117     
118      LOGICAL                                                   ::   ll_grid_crs
119      REAL(wp)                                                  ::   zval     ! valeur sur les halo
120
121      !!----------------------------------------------------------------------
122     
123      ll_grid_crs = ( jpi == jpi_crs )
124     
125      IF( PRESENT(pval) ) THEN  ;  zval = pval
126      ELSE                      ;  zval = 0.0
127      ENDIF
128     
129      IF( .NOT. ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain
130
131      IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval  )
132      ELSE                         ; CALL lbc_lnk( pt2d, cd_type, psgn, pval=zval  )
133      ENDIF
134
135      IF( .NOT. ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain
136
137   END SUBROUTINE crs_lbc_lnk_2d
138
139
140END MODULE crslbclnk
Note: See TracBrowser for help on using the repository browser.