1 | # if defined SINGLE_PRECISION |
---|
2 | # define PRECISION sp |
---|
3 | # define SENDROUTINE mppsend_sp |
---|
4 | # define RECVROUTINE mpprecv_sp |
---|
5 | # define MPI_TYPE MPI_REAL |
---|
6 | # else |
---|
7 | # define PRECISION dp |
---|
8 | # define SENDROUTINE mppsend_dp |
---|
9 | # define RECVROUTINE mpprecv_dp |
---|
10 | # define MPI_TYPE MPI_DOUBLE_PRECISION |
---|
11 | # endif |
---|
12 | |
---|
13 | SUBROUTINE ROUTINE_LNK( pt2d, cd_type, psgn, kextj) |
---|
14 | !!--------------------------------------------------------------------- |
---|
15 | !! *** routine mpp_lbc_north_icb *** |
---|
16 | !! |
---|
17 | !! ** Purpose : Ensure proper north fold horizontal bondary condition |
---|
18 | !! in mpp configuration in case of jpn1 > 1 and for 2d |
---|
19 | !! array with outer extra halo |
---|
20 | !! |
---|
21 | !! ** Method : North fold condition and mpp with more than one proc |
---|
22 | !! in i-direction require a specific treatment. We gather |
---|
23 | !! the 4+kextj northern lines of the global domain on 1 |
---|
24 | !! processor and apply lbc north-fold on this sub array. |
---|
25 | !! Then we scatter the north fold array back to the processors. |
---|
26 | !! This routine accounts for an extra halo with icebergs |
---|
27 | !! and assumes ghost rows and columns have been suppressed. |
---|
28 | !! |
---|
29 | !!---------------------------------------------------------------------- |
---|
30 | REAL(PRECISION), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo |
---|
31 | CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points |
---|
32 | ! ! = T , U , V , F or W -points |
---|
33 | REAL(PRECISION) , INTENT(in ) :: psgn ! = -1. the sign change across the |
---|
34 | !! ! north fold, = 1. otherwise |
---|
35 | INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold |
---|
36 | ! |
---|
37 | INTEGER :: ji, jj, jr |
---|
38 | INTEGER :: ierr, itaille |
---|
39 | INTEGER :: ipj, ij, iproc, ijnr, ii1, ipi, impp |
---|
40 | ! |
---|
41 | REAL(PRECISION), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e |
---|
42 | REAL(PRECISION), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e |
---|
43 | !!---------------------------------------------------------------------- |
---|
44 | #if ! defined key_mpi_off |
---|
45 | ! |
---|
46 | ipj=4 |
---|
47 | ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & |
---|
48 | & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & |
---|
49 | & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,ndim_rank_north) ) |
---|
50 | ! |
---|
51 | # if defined SINGLE_PRECISION |
---|
52 | ztab_e(:,:) = 0._sp |
---|
53 | znorthloc_e(:,:) = 0._sp |
---|
54 | # else |
---|
55 | ztab_e(:,:) = 0._dp |
---|
56 | znorthloc_e(:,:) = 0._dp |
---|
57 | # endif |
---|
58 | ! |
---|
59 | ij = 1 - kextj |
---|
60 | ! put the last ipj+2*kextj lines of pt2d into znorthloc_e |
---|
61 | DO jj = jpj - ipj + 1 - kextj , jpj + kextj |
---|
62 | znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) |
---|
63 | ij = ij + 1 |
---|
64 | END DO |
---|
65 | ! |
---|
66 | itaille = jpimax * ( ipj + 2*kextj ) |
---|
67 | ! |
---|
68 | IF( ln_timing ) CALL tic_tac(.TRUE.) |
---|
69 | #if ! defined key_mpi_off |
---|
70 | CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_TYPE, & |
---|
71 | & znorthgloio_e(1,1-kextj,1), itaille, MPI_TYPE, & |
---|
72 | & ncomm_north, ierr ) |
---|
73 | #endif |
---|
74 | ! |
---|
75 | IF( ln_timing ) CALL tic_tac(.FALSE.) |
---|
76 | ! |
---|
77 | ijnr = 0 |
---|
78 | DO jr = 1, ndim_rank_north ! recover the global north array |
---|
79 | iproc = nfproc(jr) |
---|
80 | IF( iproc /= -1 ) THEN |
---|
81 | impp = nfimpp(jr) |
---|
82 | ipi = nfjpi(jr) |
---|
83 | ijnr = ijnr + 1 |
---|
84 | DO jj = 1-kextj, ipj+kextj |
---|
85 | DO ji = 1, ipi |
---|
86 | ii1 = impp + ji - 1 ! corresponds to mig(ji) but for subdomain iproc |
---|
87 | ztab_e(ii1,jj) = znorthgloio_e(ji,jj,ijnr) |
---|
88 | END DO |
---|
89 | END DO |
---|
90 | ENDIF |
---|
91 | END DO |
---|
92 | |
---|
93 | ! 2. North-Fold boundary conditions |
---|
94 | ! ---------------------------------- |
---|
95 | CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) |
---|
96 | |
---|
97 | ij = 1 - kextj |
---|
98 | !! Scatter back to pt2d |
---|
99 | DO jj = jpj - ipj + 1 - kextj , jpj + kextj |
---|
100 | DO ji= 1, jpi |
---|
101 | pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) |
---|
102 | END DO |
---|
103 | ij = ij +1 |
---|
104 | END DO |
---|
105 | ! |
---|
106 | DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) |
---|
107 | ! |
---|
108 | #endif |
---|
109 | END SUBROUTINE ROUTINE_LNK |
---|
110 | |
---|
111 | # undef PRECISION |
---|
112 | # undef SENDROUTINE |
---|
113 | # undef RECVROUTINE |
---|
114 | # undef MPI_TYPE |
---|