source: branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/lbc_lnk_generic.h90 @ 8882

Last change on this file since 8882 was 8882, checked in by flavoni, 3 years ago

dev_CNRS_2017 branch: merged dev_r7881_ENHANCE09_RK3 with trunk r8864

File size: 5.4 KB
Line 
1#if defined MULTI
2#   define NAT_IN(k)                cd_nat(k)   
3#   define SGN_IN(k)                psgn(k)
4#   define F_SIZE(ptab)             kfld
5#   if defined DIM_2d
6#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)                , INTENT(inout) ::   ptab(f)
7#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j)
8#      define K_SIZE(ptab)             1
9#      define L_SIZE(ptab)             1
10#   endif
11#   if defined DIM_3d
12#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D),INTENT(inout)::ptab(f)
13#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
14#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
15#      define L_SIZE(ptab)             1
16#   endif
17#   if defined DIM_4d
18#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D),INTENT(inout)::ptab(f)
19#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
20#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
21#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
22#   endif
23#else
24#   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f)
25#   define NAT_IN(k)                cd_nat
26#   define SGN_IN(k)                psgn
27#   define F_SIZE(ptab)             1
28#   if defined DIM_2d
29#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
30#      define K_SIZE(ptab)          1
31#      define L_SIZE(ptab)          1
32#   endif
33#   if defined DIM_3d
34#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
35#      define K_SIZE(ptab)          SIZE(ptab,3)
36#      define L_SIZE(ptab)          1
37#   endif
38#   if defined DIM_4d
39#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
40#      define K_SIZE(ptab)          SIZE(ptab,3)
41#      define L_SIZE(ptab)          SIZE(ptab,4)
42#   endif
43#endif
44
45#if defined MULTI
46   SUBROUTINE ROUTINE_LNK( ptab, cd_nat, psgn, kfld, cd_mpp, pval )
47      INTEGER                     , INTENT(in   ) ::   kfld        ! number of pt3d arrays
48#else
49   SUBROUTINE ROUTINE_LNK( ptab, cd_nat, psgn      , cd_mpp, pval )
50#endif
51      ARRAY_TYPE(:,:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied
52      CHARACTER(len=1)            , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
53      REAL(wp)                    , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
54      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp      ! fill the overlap area only
55      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval        ! background value (used at closed boundaries)
56      !
57      INTEGER  ::    ji,  jj,  jk,  jl, jh, jf   ! dummy loop indices
58      INTEGER  ::   ipi, ipj, ipk, ipl, ipf      ! dimension of the input array
59      REAL(wp) ::   zland
60      LOGICAL  ::   ll_Iperio, ll_Jperio, ll_nfd
61      !!----------------------------------------------------------------------
62      !
63      ipk = K_SIZE(ptab)   ! 3rd dimension
64      ipl = L_SIZE(ptab)   ! 4th    -
65      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
66      !
67      ll_Iperio = nperio==1 .OR. nperio==4 .OR. nperio==6
68      ll_Jperio = jperio==7
69      ll_nfd    = nperio==3 .OR. nperio==4 .OR. nperio==5 .OR. nperio==6
70      !
71      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
72      ELSE                         ;   zland = 0._wp     ! zero by default
73      ENDIF
74
75      ! ------------------------------- !
76      !   standard boundary treatment   !    ! CAUTION: semi-column notation is often impossible
77      ! ------------------------------- !
78      !
79      IF( PRESENT( cd_mpp ) ) THEN     !==  halos filled with inner values  ==!
80         !
81         ! only fill the overlap area and extra allows
82         ! this is in mpp case. In this module, just do nothing
83         !
84      ELSE                             !==  standard close or cyclic treatment  ==!
85         !
86         DO jf = 1, ipf                   ! number of arrays to be treated
87            !
88            !                                ! East-West boundaries
89            IF( ll_Iperio ) THEN                   !* cyclic
90               ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
91               ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf)
92            ELSE                                   !* closed
93               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN( 1 ,:,:,:,jf) = zland    ! east except F-point
94                                               ARRAY_IN(jpi,:,:,:,jf) = zland    ! west
95            ENDIF
96            !                                ! North-South boundaries
97            IF( ll_Jperio ) THEN                   !* cyclic
98               ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf)
99               ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:,   2  ,:,:,jf)
100            ELSEIF( ll_nfd ) THEN                  !* north fold
101               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:, 1 ,:,:,jf) = zland    ! south except F-point
102               CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:)  )                       ! north fold treatment         
103            ELSE                                   !* closed
104               IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:, 1 ,:,:,jf) = zland    ! south except F-point
105                                               ARRAY_IN(:,jpj,:,:,jf) = zland    ! north
106            ENDIF
107            !
108         END DO
109         !
110      ENDIF
111      !
112   END SUBROUTINE ROUTINE_LNK
113
114#undef ARRAY_TYPE
115#undef NAT_IN
116#undef SGN_IN
117#undef ARRAY_IN
118#undef K_SIZE
119#undef L_SIZE
120#undef F_SIZE
Note: See TracBrowser for help on using the repository browser.