Changeset 14433 for NEMO/trunk/src/OCE/LBC/lbc_nfd_ext_generic.h90
- Timestamp:
- 2021-02-11T09:06:49+01:00 (3 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk/src/OCE/LBC/lbc_nfd_ext_generic.h90
r13286 r14433 1 ! !== IN: ptab is an array ==!2 #define NAT_IN(k) cd_nat3 #define SGN_IN(k) psgn4 #define F_SIZE(ptab) 15 #if defined DIM_2d6 # define ARRAY_IN(i,j,k,l,f) ptab(i,j)7 # define K_SIZE(ptab) 18 # define L_SIZE(ptab) 19 #endif10 #if defined SINGLE_PRECISION11 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)12 # define PRECISION sp13 #else14 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)15 # define PRECISION dp16 #endif17 1 18 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kextj )2 SUBROUTINE lbc_nfd_ext_/**/PRECISION( ptab, cd_nat, psgn, kextj ) 19 3 !!---------------------------------------------------------------------- 20 INTEGER , INTENT(in ) :: kextj ! extra halo width at north fold, declared before its use in ARRAY_TYPE21 ARRAY_TYPE(:,1-kextj:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied22 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points23 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary4 REAL(PRECISION), DIMENSION(:,1-kextj:),INTENT(inout) :: ptab 5 CHARACTER(len=1), INTENT(in ) :: cd_nat ! nature of array grid-points 6 REAL(PRECISION), INTENT(in ) :: psgn ! sign used across the north fold boundary 7 INTEGER, INTENT(in ) :: kextj ! extra halo width at north fold 24 8 ! 25 INTEGER :: ji, jj, j k, jl, jh, jf! dummy loop indices26 INTEGER :: ip i, ipj, ipk, ipl, ipf ! dimension of the input array9 INTEGER :: ji, jj, jh ! dummy loop indices 10 INTEGER :: ipj 27 11 INTEGER :: ijt, iju, ipjm1 28 12 !!---------------------------------------------------------------------- 29 !30 ipk = K_SIZE(ptab) ! 3rd dimension31 ipl = L_SIZE(ptab) ! 4th -32 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)33 !34 13 ! 35 14 SELECT CASE ( jpni ) … … 39 18 ! 40 19 ipjm1 = ipj-1 20 ! 21 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 22 ! 23 SELECT CASE ( cd_nat ) 24 CASE ( 'T' , 'W' ) ! T-, W-point 25 DO jh = 0, kextj 26 DO ji = 2, jpiglo 27 ijt = jpiglo-ji+2 28 ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) 29 END DO 30 ptab(1,ipj+jh) = psgn * ptab(3,ipj-2-jh) 31 END DO 32 DO ji = jpiglo/2+1, jpiglo 33 ijt = jpiglo-ji+2 34 ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) 35 END DO 36 CASE ( 'U' ) ! U-point 37 DO jh = 0, kextj 38 DO ji = 2, jpiglo-1 39 iju = jpiglo-ji+1 40 ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-2-jh) 41 END DO 42 ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-2-jh) 43 ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-2-jh) 44 END DO 45 DO ji = jpiglo/2, jpiglo-1 46 iju = jpiglo-ji+1 47 ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) 48 END DO 49 CASE ( 'V' ) ! V-point 50 DO jh = 0, kextj 51 DO ji = 2, jpiglo 52 ijt = jpiglo-ji+2 53 ptab(ji,ipj-1+jh) = psgn * ptab(ijt,ipj-2-jh) 54 ptab(ji,ipj+jh ) = psgn * ptab(ijt,ipj-3-jh) 55 END DO 56 ptab(1,ipj+jh) = psgn * ptab(3,ipj-3-jh) 57 END DO 58 CASE ( 'F' ) ! F-point 59 DO jh = 0, kextj 60 DO ji = 1, jpiglo-1 61 iju = jpiglo-ji+1 62 ptab(ji,ipj-1+jh) = psgn * ptab(iju,ipj-2-jh) 63 ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-3-jh) 64 END DO 65 END DO 66 DO jh = 0, kextj 67 ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-3-jh) 68 ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-3-jh) 69 END DO 70 END SELECT 71 ! 72 ENDIF ! c_NFtype == 'T' 73 ! 74 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 75 ! 76 SELECT CASE ( cd_nat ) 77 CASE ( 'T' , 'W' ) ! T-, W-point 78 DO jh = 0, kextj 79 DO ji = 1, jpiglo 80 ijt = jpiglo-ji+1 81 ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-1-jh) 82 END DO 83 END DO 84 CASE ( 'U' ) ! U-point 85 DO jh = 0, kextj 86 DO ji = 1, jpiglo-1 87 iju = jpiglo-ji 88 ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-1-jh) 89 END DO 90 ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-1-jh) 91 END DO 92 CASE ( 'V' ) ! V-point 93 DO jh = 0, kextj 94 DO ji = 1, jpiglo 95 ijt = jpiglo-ji+1 96 ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) 97 END DO 98 END DO 99 DO ji = jpiglo/2+1, jpiglo 100 ijt = jpiglo-ji+1 101 ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) 102 END DO 103 CASE ( 'F' ) ! F-point 104 DO jh = 0, kextj 105 DO ji = 1, jpiglo-1 106 iju = jpiglo-ji 107 ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-2-jh) 108 END DO 109 ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-2-jh) 110 END DO 111 DO ji = jpiglo/2+1, jpiglo-1 112 iju = jpiglo-ji 113 ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) 114 END DO 115 END SELECT 116 ! 117 ENDIF ! c_NFtype == 'F' 118 ! 119 END SUBROUTINE lbc_nfd_ext_/**/PRECISION 41 120 42 !43 DO jf = 1, ipf ! Loop on the number of arrays to be treated44 !45 SELECT CASE ( npolj )46 !47 CASE ( 3 , 4 ) ! * North fold T-point pivot48 !49 SELECT CASE ( NAT_IN(jf) )50 CASE ( 'T' , 'W' ) ! T-, W-point51 DO jh = 0, kextj52 DO ji = 2, jpiglo53 ijt = jpiglo-ji+254 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)55 END DO56 ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-2-jh,:,:,jf)57 END DO58 DO ji = jpiglo/2+1, jpiglo59 ijt = jpiglo-ji+260 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf)61 END DO62 CASE ( 'U' ) ! U-point63 DO jh = 0, kextj64 DO ji = 2, jpiglo-165 iju = jpiglo-ji+166 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2-jh,:,:,jf)67 END DO68 ARRAY_IN( 1 ,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-2-jh,:,:,jf)69 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-2-jh,:,:,jf)70 END DO71 DO ji = jpiglo/2, jpiglo-172 iju = jpiglo-ji+173 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf)74 END DO75 CASE ( 'V' ) ! V-point76 DO jh = 0, kextj77 DO ji = 2, jpiglo78 ijt = jpiglo-ji+279 ARRAY_IN(ji,ipj-1+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)80 ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-3-jh,:,:,jf)81 END DO82 ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-3-jh,:,:,jf)83 END DO84 CASE ( 'F' ) ! F-point85 DO jh = 0, kextj86 DO ji = 1, jpiglo-187 iju = jpiglo-ji+188 ARRAY_IN(ji,ipj-1+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2-jh,:,:,jf)89 ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-3-jh,:,:,jf)90 END DO91 END DO92 DO jh = 0, kextj93 ARRAY_IN( 1 ,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-3-jh,:,:,jf)94 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-3-jh,:,:,jf)95 END DO96 END SELECT97 !98 CASE ( 5 , 6 ) ! * North fold F-point pivot99 !100 SELECT CASE ( NAT_IN(jf) )101 CASE ( 'T' , 'W' ) ! T-, W-point102 DO jh = 0, kextj103 DO ji = 1, jpiglo104 ijt = jpiglo-ji+1105 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-1-jh,:,:,jf)106 END DO107 END DO108 CASE ( 'U' ) ! U-point109 DO jh = 0, kextj110 DO ji = 1, jpiglo-1111 iju = jpiglo-ji112 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-1-jh,:,:,jf)113 END DO114 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-1-jh,:,:,jf)115 END DO116 CASE ( 'V' ) ! V-point117 DO jh = 0, kextj118 DO ji = 1, jpiglo119 ijt = jpiglo-ji+1120 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)121 END DO122 END DO123 DO ji = jpiglo/2+1, jpiglo124 ijt = jpiglo-ji+1125 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf)126 END DO127 CASE ( 'F' ) ! F-point128 DO jh = 0, kextj129 DO ji = 1, jpiglo-1130 iju = jpiglo-ji131 ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2-jh,:,:,jf)132 END DO133 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-2-jh,:,:,jf)134 END DO135 DO ji = jpiglo/2+1, jpiglo-1136 iju = jpiglo-ji137 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf)138 END DO139 END SELECT140 !141 CASE DEFAULT ! * closed : the code probably never go through142 !143 SELECT CASE ( NAT_IN(jf) )144 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points145 ARRAY_IN(:, 1:1-kextj ,:,:,jf) = 0._wp146 ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp147 CASE ( 'F' ) ! F-point148 ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp149 END SELECT150 !151 END SELECT ! npolj152 !153 END DO154 !155 END SUBROUTINE ROUTINE_NFD156 157 #undef PRECISION158 #undef ARRAY_TYPE159 #undef ARRAY_IN160 #undef NAT_IN161 #undef SGN_IN162 #undef K_SIZE163 #undef L_SIZE164 #undef F_SIZE
Note: See TracChangeset
for help on using the changeset viewer.