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