| 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(wp) , 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_mpp_mpi |
|---|
| 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 | CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_TYPE, & |
|---|
| 70 | & znorthgloio_e(1,1-kextj,1), itaille, MPI_TYPE, & |
|---|
| 71 | & ncomm_north, ierr ) |
|---|
| 72 | ! |
|---|
| 73 | IF( ln_timing ) CALL tic_tac(.FALSE.) |
|---|
| 74 | ! |
|---|
| 75 | ijnr = 0 |
|---|
| 76 | DO jr = 1, ndim_rank_north ! recover the global north array |
|---|
| 77 | iproc = nfproc(jr) |
|---|
| 78 | IF( iproc /= -1 ) THEN |
|---|
| 79 | impp = nfimpp(jr) |
|---|
| 80 | ipi = nfjpi(jr) |
|---|
| 81 | ijnr = ijnr + 1 |
|---|
| 82 | DO jj = 1-kextj, ipj+kextj |
|---|
| 83 | DO ji = 1, ipi |
|---|
| 84 | ii1 = impp + ji - 1 ! corresponds to mig(ji) but for subdomain iproc |
|---|
| 85 | ztab_e(ii1,jj) = znorthgloio_e(ji,jj,ijnr) |
|---|
| 86 | END DO |
|---|
| 87 | END DO |
|---|
| 88 | ENDIF |
|---|
| 89 | END DO |
|---|
| 90 | |
|---|
| 91 | ! 2. North-Fold boundary conditions |
|---|
| 92 | ! ---------------------------------- |
|---|
| 93 | CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) |
|---|
| 94 | |
|---|
| 95 | ij = 1 - kextj |
|---|
| 96 | !! Scatter back to pt2d |
|---|
| 97 | DO jj = jpj - ipj + 1 - kextj , jpj + kextj |
|---|
| 98 | DO ji= 1, jpi |
|---|
| 99 | pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) |
|---|
| 100 | END DO |
|---|
| 101 | ij = ij +1 |
|---|
| 102 | END DO |
|---|
| 103 | ! |
|---|
| 104 | DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) |
|---|
| 105 | ! |
|---|
| 106 | #endif |
|---|
| 107 | END SUBROUTINE ROUTINE_LNK |
|---|
| 108 | |
|---|
| 109 | # undef PRECISION |
|---|
| 110 | # undef SENDROUTINE |
|---|
| 111 | # undef RECVROUTINE |
|---|
| 112 | # undef MPI_TYPE |
|---|
