New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
crslbclnk.F90 in branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/CRS – NEMO

source: branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/CRS/crslbclnk.F90 @ 4291

Last change on this file since 4291 was 4015, checked in by cetlod, 11 years ago

2013/dev_r3940_CNRS4_IOCRS: 1st step, add new routines for outputs coarsening

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   
24CONTAINS
25
26   SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, cd_mpp, pval )
27      !!---------------------------------------------------------------------
28      !!                  ***  SUBROUTINE crs_lbc_lnk  ***
29      !!
30      !! ** Purpose :   set lateral boundary conditions for coarsened grid
31      !!
32      !! ** Method  :   Swap domain indices from full to coarse domain
33      !!                before arguments are passed directly to lbc_lnk.
34      !!                Upon exiting, switch back to full domain indices.
35      !!----------------------------------------------------------------------
36      !! Arguments
37      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type1 ! grid type
38      REAL(wp)                        , INTENT(in   )           ::   psgn     ! control of the sign
39
40      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout)   ::   pt3d1 ! 3D array on which the lbc is applied
41      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval     ! valeur sur les halo
42      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
43     
44      !! local vairables
45      LOGICAL                                                   ::   ll_grid_crs
46      REAL(wp)                                                  ::   zval     ! valeur sur les halo
47
48      !!----------------------------------------------------------------------
49     
50      ll_grid_crs = ( jpi == jpi_crs )
51     
52      IF( PRESENT(pval) ) THEN  ;  zval = pval
53      ELSE                      ;  zval = 0.0
54      ENDIF
55     
56      IF( .NOT. ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain
57
58      IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt3d1, cd_type1, psgn, cd_mpp, pval=zval  )
59      ELSE                         ; CALL lbc_lnk( pt3d1, cd_type1, psgn, pval=zval  )
60      ENDIF
61
62      IF( .NOT. ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain
63
64   END SUBROUTINE crs_lbc_lnk_3d
65   
66   SUBROUTINE crs_lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )
67      !!---------------------------------------------------------------------
68      !!                  ***  SUBROUTINE crs_lbc_lnk  ***
69      !!
70      !! ** Purpose :   set lateral boundary conditions for coarsened grid
71      !!
72      !! ** Method  :   Swap domain indices from full to coarse domain
73      !!                before arguments are passed directly to lbc_lnk.
74      !!                Upon exiting, switch back to full domain indices.
75      !!----------------------------------------------------------------------
76      !! Arguments
77      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type1,cd_type2 ! grid type
78      REAL(wp)                        , INTENT(in   )           ::   psgn     ! control of the sign
79
80      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout)   ::   pt3d1,pt3d2 ! 3D array on which the lbc is applied
81     
82      !! local vairables
83      LOGICAL                                                   ::   ll_grid_crs
84      !!----------------------------------------------------------------------
85     
86      ll_grid_crs = ( jpi == jpi_crs )
87     
88      IF( .NOT. ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain
89
90      CALL lbc_lnk( pt3d1, cd_type1, pt3d2, cd_type2, psgn  )
91
92      IF( .NOT. ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain
93
94   END SUBROUTINE crs_lbc_lnk_3d_gather
95
96   
97   
98   SUBROUTINE crs_lbc_lnk_2d(pt2d, cd_type, psgn, cd_mpp, pval)
99      !!---------------------------------------------------------------------
100      !!                  ***  SUBROUTINE crs_lbc_lnk  ***
101      !!
102      !! ** Purpose :   set lateral boundary conditions for coarsened grid
103      !!
104      !! ** Method  :   Swap domain indices from full to coarse domain
105      !!                before arguments are passed directly to lbc_lnk.
106      !!                Upon exiting, switch back to full domain indices.
107      !!----------------------------------------------------------------------
108      !! Arguments
109      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type  ! grid type
110      REAL(wp)                        , INTENT(in   )           ::   psgn     ! control of the sign
111
112      REAL(wp), DIMENSION(jpi_crs,jpj_crs),     INTENT(inout)   ::   pt2d     ! 2D array on which the lbc is applied
113      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval     ! valeur sur les halo
114      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp   ! MPP only (here do nothing)
115      !! local variables
116     
117      LOGICAL                                                   ::   ll_grid_crs
118      REAL(wp)                                                  ::   zval     ! valeur sur les halo
119
120      !!----------------------------------------------------------------------
121     
122      ll_grid_crs = ( jpi == jpi_crs )
123     
124      IF( PRESENT(pval) ) THEN  ;  zval = pval
125      ELSE                      ;  zval = 0.0
126      ENDIF
127     
128      IF( .NOT. ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain
129
130      IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval  )
131      ELSE                         ; CALL lbc_lnk( pt2d, cd_type, psgn, pval=zval  )
132      ENDIF
133
134      IF( .NOT. ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain
135
136   END SUBROUTINE crs_lbc_lnk_2d
137
138
139END MODULE crslbclnk
Note: See TracBrowser for help on using the repository browser.