[12632] | 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, ildi, ilei, iilb |
---|
| 39 | INTEGER :: ipj, ij, iproc |
---|
| 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,jpni) ) |
---|
| 50 | ! |
---|
[13221] | 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 |
---|
[12632] | 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 | DO jr = 1, ndim_rank_north ! recover the global north array |
---|
| 76 | iproc = nrank_north(jr) + 1 |
---|
| 77 | ildi = nldit (iproc) |
---|
| 78 | ilei = nleit (iproc) |
---|
| 79 | iilb = nimppt(iproc) |
---|
| 80 | DO jj = 1-kextj, ipj+kextj |
---|
| 81 | DO ji = ildi, ilei |
---|
| 82 | ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) |
---|
| 83 | END DO |
---|
| 84 | END DO |
---|
| 85 | END DO |
---|
| 86 | |
---|
| 87 | ! 2. North-Fold boundary conditions |
---|
| 88 | ! ---------------------------------- |
---|
| 89 | CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) |
---|
| 90 | |
---|
| 91 | ij = 1 - kextj |
---|
| 92 | !! Scatter back to pt2d |
---|
| 93 | DO jj = jpj - ipj + 1 - kextj , jpj + kextj |
---|
| 94 | DO ji= 1, jpi |
---|
| 95 | pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) |
---|
| 96 | END DO |
---|
| 97 | ij = ij +1 |
---|
| 98 | END DO |
---|
| 99 | ! |
---|
| 100 | DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) |
---|
| 101 | ! |
---|
| 102 | #endif |
---|
| 103 | END SUBROUTINE ROUTINE_LNK |
---|
| 104 | |
---|
| 105 | # undef PRECISION |
---|
| 106 | # undef SENDROUTINE |
---|
| 107 | # undef RECVROUTINE |
---|
| 108 | # undef MPI_TYPE |
---|