[8586] | 1 | |
---|
[14433] | 2 | SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, khls, kfld ) |
---|
| 3 | TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. |
---|
| 4 | CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points |
---|
| 5 | REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary |
---|
| 6 | INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls |
---|
| 7 | INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays |
---|
[8586] | 8 | ! |
---|
[13286] | 9 | INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices |
---|
[14433] | 10 | INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array |
---|
[13286] | 11 | INTEGER :: ii1, ii2, ij1, ij2 |
---|
[8586] | 12 | !!---------------------------------------------------------------------- |
---|
| 13 | ! |
---|
[14433] | 14 | ipi = SIZE(ptab(1)%pt4d,1) |
---|
| 15 | ipj = SIZE(ptab(1)%pt4d,2) |
---|
| 16 | ipk = SIZE(ptab(1)%pt4d,3) |
---|
| 17 | ipl = SIZE(ptab(1)%pt4d,4) |
---|
| 18 | ipf = kfld |
---|
[8586] | 19 | ! |
---|
[14433] | 20 | IF( ipi /= Ni0glo+2*khls ) THEN |
---|
| 21 | WRITE(ctmp1,*) 'lbc_nfd input array does not match khls', ipi, khls, Ni0glo |
---|
| 22 | CALL ctl_stop( 'STOP', ctmp1 ) |
---|
| 23 | ENDIF |
---|
| 24 | ! |
---|
[8586] | 25 | DO jf = 1, ipf ! Loop on the number of arrays to be treated |
---|
| 26 | ! |
---|
[14433] | 27 | IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot |
---|
[8586] | 28 | ! |
---|
[14433] | 29 | SELECT CASE ( cd_nat(jf) ) |
---|
[8586] | 30 | CASE ( 'T' , 'W' ) ! T-, W-point |
---|
[15267] | 31 | DO jl = 1, ipl ; DO jk = 1, ipk |
---|
[13286] | 32 | ! |
---|
[14433] | 33 | ! last khls lines (from ipj to ipj-khls+1) : full |
---|
| 34 | DO jj = 1, khls |
---|
| 35 | ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 |
---|
| 36 | ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 |
---|
[13286] | 37 | ! |
---|
[14433] | 38 | DO ji = 1, khls ! first khls points |
---|
| 39 | ii1 = ji ! ends at: khls |
---|
| 40 | ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 |
---|
| 41 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 42 | END DO |
---|
[14433] | 43 | DO ji = 1, 1 ! point khls+1 |
---|
| 44 | ii1 = khls + ji |
---|
[13286] | 45 | ii2 = ii1 |
---|
[14433] | 46 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 47 | END DO |
---|
[14433] | 48 | DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) |
---|
| 49 | ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls |
---|
| 50 | ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 |
---|
| 51 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 52 | END DO |
---|
[14433] | 53 | DO ji = 1, 1 ! point ipi - khls + 1 |
---|
| 54 | ii1 = ipi - khls + ji |
---|
[15267] | 55 | ii2 = khls + ji |
---|
[14433] | 56 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 57 | END DO |
---|
[14433] | 58 | DO ji = 1, khls-1 ! last khls-1 points |
---|
| 59 | ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi |
---|
| 60 | ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 |
---|
| 61 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 62 | END DO |
---|
| 63 | END DO |
---|
| 64 | ! |
---|
[14433] | 65 | ! line number ipj-khls : right half |
---|
[13286] | 66 | DO jj = 1, 1 |
---|
[14433] | 67 | ij1 = ipj - khls |
---|
[13286] | 68 | ij2 = ij1 ! same line |
---|
| 69 | ! |
---|
[14433] | 70 | DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) |
---|
| 71 | ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - khls - 1) + 1 = ipi - khls |
---|
| 72 | ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls - 1) + 1 = khls + 2 |
---|
| 73 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 74 | END DO |
---|
[14433] | 75 | DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) |
---|
| 76 | ! ! as we just changed points ipi-2khls+1 to ipi-khls |
---|
| 77 | ii1 = ji ! ends at: khls |
---|
| 78 | ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 |
---|
| 79 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 80 | END DO |
---|
[14433] | 81 | ! ! last khls-1 points: have been / will done by e-w periodicity |
---|
[13286] | 82 | END DO |
---|
| 83 | ! |
---|
| 84 | END DO; END DO |
---|
[8586] | 85 | CASE ( 'U' ) ! U-point |
---|
[15267] | 86 | DO jl = 1, ipl ; DO jk = 1, ipk |
---|
[13286] | 87 | ! |
---|
[14433] | 88 | ! last khls lines (from ipj to ipj-khls+1) : full |
---|
| 89 | DO jj = 1, khls |
---|
| 90 | ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 |
---|
| 91 | ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 |
---|
[13286] | 92 | ! |
---|
[14433] | 93 | DO ji = 1, khls ! first khls points |
---|
| 94 | ii1 = ji ! ends at: khls |
---|
| 95 | ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 |
---|
| 96 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 97 | END DO |
---|
[14433] | 98 | DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) |
---|
| 99 | ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls |
---|
| 100 | ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 |
---|
| 101 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 102 | END DO |
---|
[14433] | 103 | DO ji = 1, khls ! last khls points |
---|
| 104 | ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi |
---|
[15267] | 105 | ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 |
---|
[14433] | 106 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 107 | END DO |
---|
| 108 | END DO |
---|
| 109 | ! |
---|
[14433] | 110 | ! line number ipj-khls : right half |
---|
[13286] | 111 | DO jj = 1, 1 |
---|
[14433] | 112 | ij1 = ipj - khls |
---|
[13286] | 113 | ij2 = ij1 ! same line |
---|
| 114 | ! |
---|
[14433] | 115 | DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls) |
---|
| 116 | ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls |
---|
| 117 | ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 |
---|
| 118 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 119 | END DO |
---|
[14433] | 120 | DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) |
---|
| 121 | ! ! as we just changed points ipi-2khls+1 to ipi-khls |
---|
| 122 | ii1 = ji ! ends at: khls |
---|
| 123 | ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 |
---|
| 124 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 125 | END DO |
---|
[14433] | 126 | ! ! last khls-1 points: have been / will done by e-w periodicity |
---|
[13286] | 127 | END DO |
---|
| 128 | ! |
---|
| 129 | END DO; END DO |
---|
[8586] | 130 | CASE ( 'V' ) ! V-point |
---|
[15267] | 131 | DO jl = 1, ipl ; DO jk = 1, ipk |
---|
[13286] | 132 | ! |
---|
[14433] | 133 | ! last khls+1 lines (from ipj to ipj-khls) : full |
---|
| 134 | DO jj = 1, khls+1 |
---|
| 135 | ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls |
---|
| 136 | ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 |
---|
[13286] | 137 | ! |
---|
[14433] | 138 | DO ji = 1, khls ! first khls points |
---|
| 139 | ii1 = ji ! ends at: khls |
---|
| 140 | ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 |
---|
| 141 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 142 | END DO |
---|
[14433] | 143 | DO ji = 1, 1 ! point khls+1 |
---|
| 144 | ii1 = khls + ji |
---|
[13286] | 145 | ii2 = ii1 |
---|
[14433] | 146 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 147 | END DO |
---|
[14433] | 148 | DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) |
---|
| 149 | ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls |
---|
| 150 | ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 |
---|
| 151 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 152 | END DO |
---|
[14433] | 153 | DO ji = 1, 1 ! point ipi - khls + 1 |
---|
| 154 | ii1 = ipi - khls + ji |
---|
[15267] | 155 | ii2 = khls + ji |
---|
[14433] | 156 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 157 | END DO |
---|
[14433] | 158 | DO ji = 1, khls-1 ! last khls-1 points |
---|
| 159 | ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi |
---|
| 160 | ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 |
---|
| 161 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 162 | END DO |
---|
| 163 | END DO |
---|
| 164 | ! |
---|
| 165 | END DO; END DO |
---|
[8586] | 166 | CASE ( 'F' ) ! F-point |
---|
[15267] | 167 | DO jl = 1, ipl ; DO jk = 1, ipk |
---|
[13286] | 168 | ! |
---|
[14433] | 169 | ! last khls+1 lines (from ipj to ipj-khls) : full |
---|
| 170 | DO jj = 1, khls+1 |
---|
| 171 | ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls |
---|
| 172 | ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 |
---|
[13286] | 173 | ! |
---|
[14433] | 174 | DO ji = 1, khls ! first khls points |
---|
| 175 | ii1 = ji ! ends at: khls |
---|
| 176 | ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 |
---|
| 177 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 178 | END DO |
---|
[14433] | 179 | DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) |
---|
| 180 | ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls |
---|
| 181 | ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 |
---|
| 182 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 183 | END DO |
---|
[14433] | 184 | DO ji = 1, khls ! last khls points |
---|
| 185 | ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi |
---|
[15267] | 186 | ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 |
---|
[14433] | 187 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 188 | END DO |
---|
| 189 | END DO |
---|
| 190 | ! |
---|
| 191 | END DO; END DO |
---|
[14433] | 192 | END SELECT ! cd_nat(jf) |
---|
[8586] | 193 | ! |
---|
[14433] | 194 | ENDIF ! c_NFtype == 'T' |
---|
| 195 | ! |
---|
| 196 | IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot |
---|
[8586] | 197 | ! |
---|
[14433] | 198 | SELECT CASE ( cd_nat(jf) ) |
---|
[8586] | 199 | CASE ( 'T' , 'W' ) ! T-, W-point |
---|
[15267] | 200 | DO jl = 1, ipl ; DO jk = 1, ipk |
---|
[13286] | 201 | ! |
---|
[14433] | 202 | ! first: line number ipj-khls : 3 points |
---|
[13286] | 203 | DO jj = 1, 1 |
---|
[14433] | 204 | ij1 = ipj - khls |
---|
[13286] | 205 | ij2 = ij1 ! same line |
---|
| 206 | ! |
---|
[14433] | 207 | DO ji = 1, 1 ! points from ipi/2+1 |
---|
| 208 | ii1 = ipi/2 + ji |
---|
| 209 | ii2 = ipi/2 - ji + 1 |
---|
| 210 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... |
---|
[13286] | 211 | END DO |
---|
[14433] | 212 | DO ji = 1, 1 ! points ipi - khls |
---|
| 213 | ii1 = ipi - khls + ji - 1 |
---|
[15267] | 214 | ii2 = khls + ji |
---|
[14433] | 215 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... |
---|
[13286] | 216 | END DO |
---|
[14433] | 217 | DO ji = 1, 1 ! point khls: redo it just in case (if e-w periodocity already done) |
---|
| 218 | ! ! as we just changed point ipi - khls |
---|
| 219 | ii1 = khls + ji - 1 |
---|
| 220 | ii2 = khls + ji |
---|
| 221 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... |
---|
[13286] | 222 | END DO |
---|
| 223 | END DO |
---|
| 224 | ! |
---|
[14433] | 225 | ! Second: last khls lines (from ipj to ipj-khls+1) : full |
---|
| 226 | DO jj = 1, khls |
---|
| 227 | ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls |
---|
| 228 | ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls |
---|
[13286] | 229 | ! |
---|
[14433] | 230 | DO ji = 1, khls ! first khls points |
---|
| 231 | ii1 = ji ! ends at: khls |
---|
| 232 | ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 |
---|
| 233 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 234 | END DO |
---|
[14433] | 235 | DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) |
---|
| 236 | ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls |
---|
| 237 | ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 |
---|
| 238 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 239 | END DO |
---|
[14433] | 240 | DO ji = 1, khls ! last khls points |
---|
| 241 | ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi |
---|
[15267] | 242 | ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 |
---|
[14433] | 243 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 244 | END DO |
---|
| 245 | END DO |
---|
| 246 | ! |
---|
| 247 | END DO; END DO |
---|
[8586] | 248 | CASE ( 'U' ) ! U-point |
---|
[15267] | 249 | DO jl = 1, ipl ; DO jk = 1, ipk |
---|
[13286] | 250 | ! |
---|
[14433] | 251 | ! last khls lines (from ipj to ipj-khls+1) : full |
---|
| 252 | DO jj = 1, khls |
---|
| 253 | ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls |
---|
| 254 | ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls |
---|
[13286] | 255 | ! |
---|
[14433] | 256 | DO ji = 1, khls-1 ! first khls-1 points |
---|
| 257 | ii1 = ji ! ends at: khls-1 |
---|
| 258 | ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 |
---|
| 259 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 260 | END DO |
---|
[14433] | 261 | DO ji = 1, 1 ! point khls |
---|
| 262 | ii1 = khls + ji - 1 |
---|
| 263 | ii2 = ipi - ii1 |
---|
| 264 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 265 | END DO |
---|
[14433] | 266 | DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls) |
---|
| 267 | ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 |
---|
| 268 | ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 |
---|
| 269 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 270 | END DO |
---|
[14433] | 271 | DO ji = 1, 1 ! point ipi - khls |
---|
| 272 | ii1 = ipi - khls + ji - 1 |
---|
[13286] | 273 | ii2 = ii1 |
---|
[14433] | 274 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 275 | END DO |
---|
[14433] | 276 | DO ji = 1, khls ! last khls points |
---|
| 277 | ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi |
---|
| 278 | ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls |
---|
| 279 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 280 | END DO |
---|
| 281 | END DO |
---|
| 282 | ! |
---|
| 283 | END DO; END DO |
---|
[8586] | 284 | CASE ( 'V' ) ! V-point |
---|
[15267] | 285 | DO jl = 1, ipl ; DO jk = 1, ipk |
---|
[13286] | 286 | ! |
---|
[14433] | 287 | ! last khls lines (from ipj to ipj-khls+1) : full |
---|
| 288 | DO jj = 1, khls |
---|
| 289 | ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 |
---|
| 290 | ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 |
---|
[13286] | 291 | ! |
---|
[14433] | 292 | DO ji = 1, khls ! first khls points |
---|
| 293 | ii1 = ji ! ends at: khls |
---|
| 294 | ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 |
---|
| 295 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 296 | END DO |
---|
[14433] | 297 | DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) |
---|
| 298 | ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls |
---|
| 299 | ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 |
---|
| 300 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 301 | END DO |
---|
[14433] | 302 | DO ji = 1, khls ! last khls points |
---|
| 303 | ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi |
---|
[15267] | 304 | ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 |
---|
[14433] | 305 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 306 | END DO |
---|
| 307 | END DO |
---|
| 308 | ! |
---|
[14433] | 309 | ! line number ipj-khls : right half |
---|
[13286] | 310 | DO jj = 1, 1 |
---|
[14433] | 311 | ij1 = ipj - khls |
---|
[13286] | 312 | ij2 = ij1 ! same line |
---|
| 313 | ! |
---|
[14433] | 314 | DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls) |
---|
| 315 | ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls |
---|
| 316 | ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 |
---|
| 317 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 318 | END DO |
---|
[14433] | 319 | DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) |
---|
| 320 | ! ! as we just changed points ipi-2khls+1 to ipi-khls |
---|
| 321 | ii1 = ji ! ends at: khls |
---|
| 322 | ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 |
---|
| 323 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 324 | END DO |
---|
[14433] | 325 | ! ! last khls points: have been / will done by e-w periodicity |
---|
[13286] | 326 | END DO |
---|
| 327 | ! |
---|
| 328 | END DO; END DO |
---|
[8586] | 329 | CASE ( 'F' ) ! F-point |
---|
[15267] | 330 | DO jl = 1, ipl ; DO jk = 1, ipk |
---|
[13286] | 331 | ! |
---|
[14433] | 332 | ! last khls lines (from ipj to ipj-khls+1) : full |
---|
| 333 | DO jj = 1, khls |
---|
| 334 | ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 |
---|
| 335 | ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 |
---|
[13286] | 336 | ! |
---|
[14433] | 337 | DO ji = 1, khls-1 ! first khls-1 points |
---|
| 338 | ii1 = ji ! ends at: khls-1 |
---|
| 339 | ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 |
---|
| 340 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 341 | END DO |
---|
[14433] | 342 | DO ji = 1, 1 ! point khls |
---|
| 343 | ii1 = khls + ji - 1 |
---|
| 344 | ii2 = ipi - ii1 |
---|
| 345 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 346 | END DO |
---|
[14433] | 347 | DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls) |
---|
| 348 | ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 |
---|
| 349 | ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 |
---|
| 350 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 351 | END DO |
---|
[14433] | 352 | DO ji = 1, 1 ! point ipi - khls |
---|
| 353 | ii1 = ipi - khls + ji - 1 |
---|
[13286] | 354 | ii2 = ii1 |
---|
[14433] | 355 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 356 | END DO |
---|
[14433] | 357 | DO ji = 1, khls ! last khls points |
---|
| 358 | ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi |
---|
| 359 | ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls |
---|
| 360 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 361 | END DO |
---|
| 362 | END DO |
---|
| 363 | ! |
---|
[14433] | 364 | ! line number ipj-khls : right half |
---|
[13286] | 365 | DO jj = 1, 1 |
---|
[14433] | 366 | ij1 = ipj - khls |
---|
[13286] | 367 | ij2 = ij1 ! same line |
---|
| 368 | ! |
---|
[14433] | 369 | DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - khls-1 (note: Ni0glo = ipi - 2*khls) |
---|
| 370 | ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls |
---|
| 371 | ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - khls - 1 ) = khls + 1 |
---|
| 372 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 373 | END DO |
---|
[14433] | 374 | DO ji = 1, khls-1 ! first khls-1 points: redo them just in case (if e-w periodocity already done) |
---|
| 375 | ! ! as we just changed points ipi-2khls+1 to ipi-nn_hl-1 |
---|
| 376 | ii1 = ji ! ends at: khls |
---|
| 377 | ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 |
---|
| 378 | ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) |
---|
[13286] | 379 | END DO |
---|
[14433] | 380 | ! ! last khls points: have been / will done by e-w periodicity |
---|
[13286] | 381 | END DO |
---|
| 382 | ! |
---|
| 383 | END DO; END DO |
---|
[14433] | 384 | END SELECT ! cd_nat(jf) |
---|
[8586] | 385 | ! |
---|
[14433] | 386 | ENDIF ! c_NFtype == 'F' |
---|
[8586] | 387 | ! |
---|
[13286] | 388 | END DO ! ipf |
---|
[8586] | 389 | ! |
---|
[14433] | 390 | END SUBROUTINE lbc_nfd_/**/PRECISION |
---|
[8586] | 391 | |
---|