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.
Changeset 12325 for NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/halo_mng.F90 – NEMO

Ignore:
Timestamp:
2020-01-15T13:26:22+01:00 (4 years ago)
Author:
francesca
Message:

replace halo-copy routines - ticket #2009

File:
1 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/halo_mng.F90

    r11720 r12325  
    1111 
    1212   USE dom_oce       ! ocean space and time domain 
     13   USE lbclnk        ! ocean lateral boundary condition (or mpp link)  
    1314 
    1415   IMPLICIT NONE 
    1516   PRIVATE 
    1617 
    17    INTERFACE halo_mng_copy 
    18       MODULE PROCEDURE halo_mng_copy_2D, halo_mng_copy_3d, halo_mng_copy_4d 
     18   INTERFACE halo_mng_resize 
     19      MODULE PROCEDURE halo_mng_resize_2D, halo_mng_resize_3d, halo_mng_resize_4d 
    1920   END INTERFACE 
    2021 
    21    PUBLIC halo_mng_copy 
     22   PUBLIC halo_mng_resize 
    2223   PUBLIC halo_mng_init 
    2324   PUBLIC halo_mng_set 
    … …  
    6768   END SUBROUTINE halo_mng_set 
    6869    
    69    SUBROUTINE halo_mng_copy_2D(pta_1, pta_2) 
    70       !!---------------------------------------------------------------------- 
    71       !!                  ***  ROUTINE halo_mng_copy  *** 
    72       !! 
    73       !! ** Purpose : copy pta_1 into pta_2 
    74       !! ** Method  : 
    75       !! History : 
    76       !!   1.0  !  07-19  ( CMCC - ASC )  halo_mng_copy 
    77       !!---------------------------------------------------------------------- 
    78        REAL(wp), DIMENSION(:,:), INTENT(in)  :: pta_1 
    79        REAL(wp), DIMENSION(:,:), INTENT(out)  :: pta_2 
    80        INTEGER :: halo, off1, off2 
    81        INTEGER, DIMENSION(2) :: dim 
     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 
    8279 
    83        halo = (SIZE(pta_1,1) - SIZE(pta_2,1))/2 
    84        IF (halo < 0) THEN 
    85           off1 = 0 
    86           off2 = -halo 
    87           dim = SHAPE(pta_1) 
    88        ELSE 
    89           off1 = halo 
    90           off2 = 0 
    91           dim = SHAPE(pta_2) 
    92        END IF 
    93          
    94        pta_2(1+off2:SIZE(pta_2,1)-off2, 1+off2:SIZE(pta_2,2)-off2) = pta_1(1+off1:SIZE(pta_1,1)-off1, 1+off1:SIZE(pta_1,2)-off1) 
    95         
    96      
    97    END SUBROUTINE halo_mng_copy_2D 
     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  
    9889 
    99    SUBROUTINE halo_mng_copy_3D(pta_1, pta_2) 
    100       !!---------------------------------------------------------------------- 
    101       !!                  ***  ROUTINE halo_mng_copy  *** 
    102       !! 
    103       !! ** Purpose : copy pta_1 into pta_2 
    104       !! ** Method  : 
    105       !! History : 
    106       !!   1.0  !  07-19  ( CMCC - ASC )  halo_mng_copy 
    107       !!---------------------------------------------------------------------- 
    108        REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pta_1 
    109        REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pta_2 
     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 
    110101 
    111        INTEGER :: halo, off1, off2 
    112        INTEGER, DIMENSION(3) :: dim 
     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 
    113111 
    114        halo = (SIZE(pta_1,1) - SIZE(pta_2,1))/2 
    115        IF (halo < 0) THEN 
    116           off1 = 0 
    117           off2 = -halo 
    118           dim = SHAPE(pta_1) 
    119        ELSE 
    120           off1 = halo 
    121           off2 = 0 
    122           dim = SHAPE(pta_2) 
    123        END IF 
    124          
    125        pta_2(1+off2:SIZE(pta_2,1)-off2, 1+off2:SIZE(pta_2,2)-off2,:) = pta_1(1+off1:SIZE(pta_1,1)-off1, 1+off1:SIZE(pta_1,2)-off1,:)  
     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  
    126121 
    127    END SUBROUTINE halo_mng_copy_3D 
     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 
    128133 
    129    SUBROUTINE halo_mng_copy_4D(pta_1, pta_2) 
    130       !!---------------------------------------------------------------------- 
    131       !!                  ***  ROUTINE halo_mng_copy  *** 
    132       !! 
    133       !! ** Purpose : copy pta_1 into pta_2 
    134       !! ** Method  : 
    135       !! History : 
    136       !!   1.0  !  07-19  ( CMCC - ASC )  halo_mng_copy 
    137       !!---------------------------------------------------------------------- 
    138        REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: pta_1 
    139        REAL(wp), DIMENSION(:,:,:,:), INTENT(out) :: pta_2 
    140        INTEGER :: halo, off1, off2 
    141        INTEGER, DIMENSION(4) :: dim 
     134   SUBROUTINE halo_mng_resize_4D(pta, cdna, psgn, fillval, kjpt) 
     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 , OPTIONAL, INTENT(in) ::   kjpt            ! number of tracers 
     141      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zpta 
     142      INTEGER :: offset 
     143      INTEGER :: pta_size_i, pta_size_j, exp_size_i, exp_size_j 
    142144 
    143        halo = (SIZE(pta_1,1) - SIZE(pta_2,1))/2 
    144        IF (halo < 0) THEN 
    145           off1 = 0 
    146           off2 = -halo 
    147           dim = SHAPE(pta_1) 
    148        ELSE 
    149           off1 = halo 
    150           off2 = 0 
    151           dim = SHAPE(pta_2) 
    152        END IF 
    153          
    154        pta_2(1+off2:SIZE(pta_2,1)-off2, 1+off2:SIZE(pta_2,2)-off2,:,:) = pta_1(1+off1:SIZE(pta_1,1)-off1, 1+off1:SIZE(pta_1,2)-off1,:,:) 
     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, kjpt)) 
     153         offset = (exp_size_i - pta_size_i) / 2  
    155154 
    156    END SUBROUTINE halo_mng_copy_4D 
     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, cdna, psgn, pfillval=fillval) 
     161         DEALLOCATE(pta) 
     162         pta => zpta 
     163      END IF 
     164       
     165   END SUBROUTINE halo_mng_resize_4D 
     166    
    157167END MODULE 
Note: See TracChangeset for help on using the changeset viewer.