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.
lbc_lnk_call_generic.h90 in NEMO/trunk/src/OCE/LBC – NEMO

source: NEMO/trunk/src/OCE/LBC/lbc_lnk_call_generic.h90

Last change on this file was 15354, checked in by smasson, 3 years ago

trunk: BDY compliant with corner communications, see #2731
  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 10.5 KB
RevLine 
[14338]1#if defined DIM_2d
[14349]2#   define XD     2d
3#   define DIMS   :,:
4#   define ISZ3   1 
5#   define ISZ4   1   
[8586]6#endif
[14338]7#if defined DIM_3d
[14349]8#   define XD     3d
9#   define DIMS   :,:,:
10#   define ISZ3   SIZE(ptab, dim=3)
11#   define ISZ4   1
[14338]12#endif
13#if defined DIM_4d
[14349]14#   define XD     4d
15#   define DIMS   :,:,:,:
16#   define ISZ3   SIZE(ptab, dim=3)
17#   define ISZ4   SIZE(ptab, dim=4)
[14338]18#endif
[11536]19
[15048]20   SUBROUTINE lbc_lnk_call_/**/XD/**/_/**/PRECISION(                                                                &
[14338]21      &                     cdname                                                                                  &
22      &                   , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4   &
23      &                   , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8   &
24      &                   , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12  &
25      &                   , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16  &
[15048]26      &                   , pt17, cdna17, psgn17, pt18, cdna18, psgn18, pt19, cdna19, psgn19, pt20, cdna20, psgn20  &
27      &                   , pt21, cdna21, psgn21, pt22, cdna22, psgn22, pt23, cdna23, psgn23, pt24, cdna24, psgn24  &
28      &                   , pt25, cdna25, psgn25, pt26, cdna26, psgn26, pt27, cdna27, psgn27, pt28, cdna28, psgn28  &
29      &                   , pt29, cdna29, psgn29, pt30, cdna30, psgn30                                              &
[14366]30      &                   , kfillmode, pfillval, khls, lsend, lrecv, ld4only )
[8586]31      !!---------------------------------------------------------------------
[13472]32      CHARACTER(len=*)     ,                   INTENT(in   ) ::   cdname  ! name of the calling subroutine
[14349]33      REAL(PRECISION), DIMENSION(DIMS)          , TARGET, CONTIGUOUS, INTENT(inout) ::   pt1        ! arrays on which the lbc is applied
[15048]34      REAL(PRECISION), DIMENSION(DIMS), OPTIONAL, TARGET, CONTIGUOUS, INTENT(inout) ::   pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , &
35         &                                                                               pt9 , pt10, pt11, pt12, pt13, pt14, pt15, &
36         &                                                                               pt16, pt17, pt18, pt19, pt20, pt21, pt22, &
37         &                                                                               pt23, pt24, pt25, pt26, pt27, pt28, pt29, &
38         &                                                                               pt30
[13472]39      CHARACTER(len=1)                       , INTENT(in   ) ::   cdna1   ! nature of pt2D. array grid-points
[15048]40      CHARACTER(len=1)     , OPTIONAL        , INTENT(in   ) ::   cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , &
41         &                                                        cdna9 , cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, &
42         &                                                        cdna16, cdna17, cdna18, cdna19, cdna20, cdna21, cdna22, &
43         &                                                        cdna23, cdna24, cdna25, cdna26, cdna27, cdna28, cdna29, &
44         &                                                        cdna30
[14314]45      REAL(PRECISION)                        , INTENT(in   ) ::   psgn1   ! sign used across the north fold
[15048]46      REAL(PRECISION)      , OPTIONAL        , INTENT(in   ) ::   psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , &
47         &                                                        psgn9 , psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, &
48         &                                                        psgn16, psgn17, psgn18, psgn19, psgn20, psgn21, psgn22, &
49         &                                                        psgn23, psgn24, psgn25, psgn26, psgn27, psgn28, psgn29, &
50         &                                                        psgn30
[13472]51      INTEGER              , OPTIONAL        , INTENT(in   ) ::   kfillmode   ! filling method for halo over land (default = constant)
[14314]52      REAL(PRECISION)      , OPTIONAL        , INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries)
[14363]53      INTEGER              , OPTIONAL        , INTENT(in   ) ::   khls        ! halo size, default = nn_hls
[15354]54      LOGICAL, DIMENSION(8), OPTIONAL        , INTENT(in   ) ::   lsend, lrecv   ! indicate how communications are to be carried out
[14366]55      LOGICAL              , OPTIONAL        , INTENT(in   ) ::   ld4only     ! if .T., do only 4-neighbour comm (ignore corners)
[8586]56      !!
[11536]57      INTEGER                          ::   kfld        ! number of elements that will be attributed
[15048]58      TYPE(PTR_4d_/**/PRECISION), DIMENSION(30) ::   ptab_ptr    ! pointer array
59      CHARACTER(len=1) , DIMENSION(30) ::   cdna_ptr    ! nature of ptab_ptr grid-points
60      REAL(PRECISION)  , DIMENSION(30) ::   psgn_ptr    ! sign used across the north fold boundary
[8586]61      !!---------------------------------------------------------------------
62      !
63      kfld = 0          ! initial array of pointer size
64      !
65      !                 ! Load the first array
[14338]66      CALL load_ptr_/**/XD/**/_/**/PRECISION( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
[8586]67      !
68      !                 ! Look if more arrays are added
[14338]69      IF( PRESENT(psgn2 ) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )
70      IF( PRESENT(psgn3 ) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )
71      IF( PRESENT(psgn4 ) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )
72      IF( PRESENT(psgn5 ) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )
73      IF( PRESENT(psgn6 ) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )
74      IF( PRESENT(psgn7 ) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )
75      IF( PRESENT(psgn8 ) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )
76      IF( PRESENT(psgn9 ) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld )
77      IF( PRESENT(psgn10) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
78      IF( PRESENT(psgn11) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
79      IF( PRESENT(psgn12) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
80      IF( PRESENT(psgn13) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
81      IF( PRESENT(psgn14) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
82      IF( PRESENT(psgn15) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
83      IF( PRESENT(psgn16) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
[15048]84      IF( PRESENT(psgn17) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt17, cdna17, psgn17, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
85      IF( PRESENT(psgn18) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt18, cdna18, psgn18, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
86      IF( PRESENT(psgn19) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt19, cdna19, psgn19, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
87      IF( PRESENT(psgn20) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt20, cdna20, psgn20, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
88      IF( PRESENT(psgn21) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt21, cdna21, psgn21, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
89      IF( PRESENT(psgn22) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt22, cdna22, psgn22, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
90      IF( PRESENT(psgn23) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt23, cdna23, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
91      IF( PRESENT(psgn24) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt24, cdna24, psgn24, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
92      IF( PRESENT(psgn25) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt25, cdna25, psgn25, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
93      IF( PRESENT(psgn26) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt26, cdna26, psgn26, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
94      IF( PRESENT(psgn27) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt27, cdna27, psgn27, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
95      IF( PRESENT(psgn28) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt28, cdna28, psgn28, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
96      IF( PRESENT(psgn29) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt29, cdna29, psgn29, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
97      IF( PRESENT(psgn30) )   CALL load_ptr_/**/XD/**/_/**/PRECISION( pt30, cdna30, psgn30, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
[14349]98      !     
[14338]99      IF( nn_comm == 1 ) THEN
[14366]100         CALL lbc_lnk_pt2pt(   cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
[14338]101      ELSE
[14366]102         CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
[14338]103      ENDIF
[8586]104      !
[14338]105   END SUBROUTINE lbc_lnk_call_/**/XD/**/_/**/PRECISION
[8586]106
107
[14338]108   SUBROUTINE load_ptr_/**/XD/**/_/**/PRECISION( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
[8586]109      !!---------------------------------------------------------------------
[14349]110      REAL(PRECISION), DIMENSION(DIMS), TARGET, INTENT(inout), CONTIGUOUS ::   ptab       ! arrays on which the lbc is applied
[8586]111      CHARACTER(len=1)              , INTENT(in   ) ::   cdna       ! nature of pt2d array grid-points
[14314]112      REAL(PRECISION)               , INTENT(in   ) ::   psgn       ! sign used across the north fold boundary
[14349]113      TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) ::   ptab_ptr   ! array of pointers
[8586]114      CHARACTER(len=1), DIMENSION(:), INTENT(inout) ::   cdna_ptr   ! nature of pt2d_array array grid-points
[14314]115      REAL(PRECISION) , DIMENSION(:), INTENT(inout) ::   psgn_ptr   ! sign used across the north fold boundary
[8586]116      INTEGER                       , INTENT(inout) ::   kfld       ! number of elements that has been attributed
117      !!---------------------------------------------------------------------
118      !
119      kfld                    =  kfld + 1
[14349]120      ptab_ptr(kfld)%pt4d(1:SIZE(ptab, dim=1),1:SIZE(ptab, dim=2),1:ISZ3,1:ISZ4) => ptab
[8586]121      cdna_ptr(kfld)          =  cdna
122      psgn_ptr(kfld)          =  psgn
123      !
[14338]124   END SUBROUTINE load_ptr_/**/XD/**/_/**/PRECISION
[11536]125
[14338]126#undef XD
[14349]127#undef DIMS
128#undef ISZ3
129#undef ISZ4
Note: See TracBrowser for help on using the repository browser.