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.
halo_mng.F90 in NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC – NEMO

source: NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/halo_mng.F90 @ 12586

Last change on this file since 12586 was 12586, checked in by francesca, 4 years ago

Add extra-halo support (jperio 3,4) - ticket #2366

File size: 6.0 KB
Line 
1MODULE halo_mng
2   !!======================================================================
3   !!                       ***  MODULE  halo_mng  ***
4   !! Ocean numerics:  massively parallel processing library
5   !!=====================================================================
6   !! History :  OPA  !  1994  (M. Guyon, J. Escobar, M. Imbard)
7   !Original code
8   !!            4.0  !  2019  (CMCC - ASC)  initial version of halo management module
9   !in_out_manager
10   !!----------------------------------------------------------------------
11
12   USE dom_oce       ! ocean space and time domain
13   USE lbclnk        ! ocean lateral boundary condition (or mpp link)
14
15   IMPLICIT NONE
16   PRIVATE
17
18   INTERFACE halo_mng_resize
19      MODULE PROCEDURE halo_mng_resize_2D, halo_mng_resize_3D, halo_mng_resize_4D, halo_mng_resize_5D
20   END INTERFACE
21
22   PUBLIC halo_mng_resize
23   PUBLIC halo_mng_init
24   PUBLIC halo_mng_set
25
26   INTEGER :: jpi_1, jpj_1
27   INTEGER :: jpimax_1, jpjmax_1
28   INTEGER :: nlci_1, nlcj_1
29   INTEGER :: jplbi_1, jplbj_1
30CONTAINS
31
32   SUBROUTINE halo_mng_init( )
33
34        jpi_1 = jpi
35        jpj_1 = jpj
36
37        nlci_1 = nlci
38        nlcj_1 = nlcj
39
40        jplbi_1 = 1 
41        jplbj_1 = 1 
42       
43        jplbi = 1 
44        jplbj = 1 
45
46         jpimax_1 = jpimax
47         jpjmax_1 = jpjmax
48
49   END SUBROUTINE halo_mng_init
50
51   SUBROUTINE halo_mng_set( khls )
52   
53        INTEGER, INTENT(in   )    ::   khls
54
55        nn_hls = khls
56        jpi = jpi_1 + khls -1
57        jpj = jpj_1 + khls -1
58
59        nlci = nlci_1 + khls -1
60        nlcj = nlcj_1 + khls -1
61       
62        jplbi = jplbi_1 - khls +1 
63        jplbj = jplbj_1 - khls +1 
64       
65        jpimax = jpimax_1 + khls -1
66        jpjmax = jpjmax_1 + khls -1
67
68   END SUBROUTINE halo_mng_set
69   
70   SUBROUTINE halo_mng_resize_2D(pta, cdna, psgn, fillval)
71   
72      REAL(wp), POINTER, DIMENSION(:,:) :: pta
73      CHARACTER(len=1), INTENT(in)  :: cdna
74      REAL(wp), INTENT(in)  :: psgn
75      REAL(wp), OPTIONAL, INTENT(in ) :: fillval
76      REAL(wp), POINTER, DIMENSION(:,:) :: zpta
77      INTEGER :: offset
78      INTEGER :: pta_size_i, pta_size_j, exp_size_i, exp_size_j
79
80      pta_size_i = SIZE(pta,1)
81      pta_size_j = SIZE(pta,2)
82      exp_size_i = jpi - jplbi + 1
83      exp_size_j = jpj - jplbj + 1
84     
85      ! check if the current size of pta is equal to the current expected dimension
86      IF (pta_size_i .ne. exp_size_i) THEN
87         ALLOCATE (zpta(jplbi:jpi, jplbj:jpj))
88         offset = (exp_size_i - pta_size_i) / 2 
89
90         IF (pta_size_i .lt. exp_size_i) THEN
91            zpta (offset+jplbi : offset+pta_size_i+jplbi-1, offset+jplbj : offset+pta_size_j+jplbj-1) = pta
92         ELSE
93            zpta = pta(jplbi : jpi, jplbj : jpj)
94         END IF
95         CALL lbc_lnk( 'halo_mng_resize_2D', zpta, cdna, psgn, pfillval=fillval)
96         DEALLOCATE(pta)
97         pta => zpta
98      END IF
99     
100   END SUBROUTINE halo_mng_resize_2D
101
102   SUBROUTINE halo_mng_resize_3D(pta, cdna, psgn, fillval)
103   
104      REAL(wp), POINTER, DIMENSION(:,:,:) :: pta
105      CHARACTER(len=1), INTENT(in)  :: cdna
106      REAL(wp), INTENT(in)  :: psgn
107      REAL(wp), OPTIONAL, INTENT(in ) :: fillval
108      REAL(wp), POINTER, DIMENSION(:,:,:) :: zpta
109      INTEGER :: offset
110      INTEGER :: pta_size_i, pta_size_j, exp_size_i, exp_size_j
111
112      pta_size_i = SIZE(pta,1)
113      pta_size_j = SIZE(pta,2)
114      exp_size_i = jpi - jplbi + 1
115      exp_size_j = jpj - jplbj + 1
116     
117      ! check if the current size of pta is equal to the current expected dimension
118      IF (pta_size_i .ne. exp_size_i) THEN
119         ALLOCATE (zpta(jplbi:jpi, jplbj:jpj, jpk))
120         offset = (exp_size_i - pta_size_i) / 2 
121
122         IF (pta_size_i .lt. exp_size_i) THEN
123            zpta (offset+jplbi : offset+pta_size_i+jplbi-1, offset+jplbj : offset+pta_size_j+jplbj-1, :) = pta
124         ELSE
125            zpta = pta(jplbi : jpi, jplbj : jpj, :)
126         END IF
127         CALL lbc_lnk( 'halo_mng_resize_3D', zpta, cdna, psgn, pfillval=fillval)
128         DEALLOCATE(pta)
129         pta => zpta
130      END IF
131     
132   END SUBROUTINE halo_mng_resize_3D
133
134   SUBROUTINE halo_mng_resize_4D(pta, cdna, psgn, fillval, fjpt)
135   
136      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: pta
137      CHARACTER(len=1), INTENT(in)  :: cdna
138      REAL(wp), INTENT(in)  :: psgn
139      REAL(wp), OPTIONAL, INTENT(in) :: fillval
140      INTEGER , INTENT(in) ::   fjpt 
141      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zpta
142      INTEGER :: offset
143      INTEGER :: pta_size_i, pta_size_j, exp_size_i, exp_size_j
144
145      pta_size_i = SIZE(pta,1)
146      pta_size_j = SIZE(pta,2)
147      exp_size_i = jpi - jplbi + 1
148      exp_size_j = jpj - jplbj + 1
149     
150      ! check if the current size of pta is equal to the current expected dimension
151      IF (pta_size_i .ne. exp_size_i) THEN
152         ALLOCATE (zpta(jplbi:jpi, jplbj:jpj, jpk, jpt))
153         offset = (exp_size_i - pta_size_i) / 2 
154
155         IF (pta_size_i .lt. exp_size_i) THEN
156            zpta (offset+jplbi : offset+pta_size_i+jplbi-1, offset+jplbj : offset+pta_size_j+jplbj-1, :, :) = pta
157         ELSE
158            zpta = pta(jplbi : jpi, jplbj : jpj, :, :)
159         END IF
160         CALL lbc_lnk( 'halo_mng_resize_4D', zpta(:,:,:,fjpt), cdna, psgn, pfillval=fillval)
161         DEALLOCATE(pta)
162         pta => zpta
163      END IF
164     
165   END SUBROUTINE halo_mng_resize_4D
166   
167   SUBROUTINE halo_mng_resize_5D(pta, cdna, psgn, fillval, kjpt, fjpt)
168   
169      REAL(wp), POINTER, DIMENSION(:,:,:,:,:) :: pta
170      CHARACTER(len=1), INTENT(in)  :: cdna
171      REAL(wp), INTENT(in)  :: psgn
172      REAL(wp), OPTIONAL, INTENT(in) :: fillval
173      INTEGER , OPTIONAL, INTENT(in) :: kjpt            ! number of tracers
174      INTEGER , INTENT(in) :: fjpt           
175      REAL(wp), POINTER, DIMENSION(:,:,:,:,:) :: zpta
176      INTEGER :: offset
177      INTEGER :: pta_size_i, pta_size_j, exp_size_i, exp_size_j
178
179      pta_size_i = SIZE(pta,1)
180      pta_size_j = SIZE(pta,2)
181      exp_size_i = jpi - jplbi + 1
182      exp_size_j = jpj - jplbj + 1
183     
184      ! check if the current size of pta is equal to the current expected dimension
185      IF (pta_size_i .ne. exp_size_i) THEN
186         ALLOCATE (zpta(jplbi:jpi, jplbj:jpj, jpk, kjpt, jpt))
187         offset = (exp_size_i - pta_size_i) / 2 
188
189         IF (pta_size_i .lt. exp_size_i) THEN
190            zpta (offset+jplbi : offset+pta_size_i+jplbi-1, offset+jplbj : offset+pta_size_j+jplbj-1, :, :, :) = pta
191         ELSE
192            zpta = pta(jplbi : jpi, jplbj : jpj, :, :, :)
193         END IF
194         CALL lbc_lnk( 'halo_mng_resize_5D', zpta(:,:,:,:,fjpt), cdna, psgn, pfillval=fillval)
195         DEALLOCATE(pta)
196         pta => zpta
197      END IF
198     
199   END SUBROUTINE halo_mng_resize_5D
200   
201END MODULE
Note: See TracBrowser for help on using the repository browser.