PageRenderTime 40ms CodeModel.GetById 1ms RepoModel.GetById 0ms app.codeStats 0ms

/wrfv2_fire/external/RSL_LITE/f_xpose.F90

http://github.com/jbeezley/wrf-fire
FORTRAN Modern | 363 lines | 330 code | 21 blank | 12 comment | 28 complexity | 30c38062be8fd847afcb5bac7d0692b2 MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1.       subroutine trans_z2x ( np, comm, dir, r_wordsize, i_wordsize, memorder, &
    2. 

  2.                                a, &
    3. 

  3.                                sd1, ed1, sd2, ed2, sd3, ed3, & 
    4. 

  4.                                sp1, ep1, sp2, ep2, sp3, ep3, & 
    5. 

  5.                                sm1, em1, sm2, em2, sm3, em3, & 
    6. 

  6.                                ax, &
    7. 

  7.                                sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, & 
    8. 

  8.                                sm1x, em1x, sm2x, em2x, sm3x, em3x )
    9. 

  9.          USE duplicate_of_driver_constants
    10. 

  10.          implicit none
    11. 

  11.          integer, intent(in) :: sd1, ed1, sd2, ed2, sd3, ed3, & 
    12. 

  12.                                 sp1, ep1, sp2, ep2, sp3, ep3, & 
    13. 

  13.                                 sm1, em1, sm2, em2, sm3, em3, & 
    14. 

  14.                                 sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, & 
    15. 

  15.                                 sm1x, em1x, sm2x, em2x, sm3x, em3x
    16. 

  16.          integer, intent(in) :: np, comm, r_wordsize, i_wordsize
    17. 

  17.          integer, intent(in) :: dir ! 1 is a->ax, otherwise ax->a
    18. 

  18.          integer, intent(in) :: memorder
    19. 

  19.          integer, dimension((ep1-sp1+1)*(ep2-sp2+1)*(ep3-sp3+1)*max(1,(r_wordsize/i_wordsize)))         :: a
    20. 

  20.          integer, dimension((ep1x-sp1x+1)*(ep2x-ep2x+1)*(ep3x-sp3x+1)*max(1,(r_wordsize/i_wordsize)))   :: ax
    21. 

  21. #ifndef STUBMPI
    22. 

  22.          include 'mpif.h'
    23. 

  23. 

  24. !local
    25. 

  25.          integer   ::         ids, ide, jds, jde, kds, kde, & 
    26. 

  26.                               ips, ipe, jps, jpe, kps, kpe, & 
    27. 

  27.                               ims, ime, jms, jme, kms, kme, & 
    28. 

  28.                               ipsx, ipex, jpsx, jpex, kpsx, kpex, & 
    29. 

  29.                               imsx, imex, jmsx, jmex, kmsx, kmex
    30. 

  30. 

  31.          integer, dimension(0:(ep1-sp1+1)*(ep2-sp2+1)*(ep3-sp3+1)*max(1,(r_wordsize/i_wordsize)))       :: zbuf
    32. 

  32.          integer, dimension(0:(ep1x-sp1x+1)*(ep2x-sp2x+1)*(ep3x-sp3x+1)*max(1,(r_wordsize/i_wordsize))) :: xbuf
    33. 

  33. 

  34.          integer pencil(4), allpencils(4,np)
    35. 

  35.          integer sendcnts(np), sdispls(np), recvcnts(np), rdispls(np)
    36. 

  36.          integer allsendcnts(np+2,np), is(np), ie(np), ks(np),ke(np)
    37. 

  37.          integer sendcurs(np), recvcurs(np)
    38. 

  38.          integer i,j,k,p,sc,sp,rp,yp,zp,curs,zbufsz,cells,nkcells,ivectype,ierr
    39. 

  39. 

  40.          SELECT CASE ( memorder )
    41. 

  41.           CASE ( DATA_ORDER_XYZ )
    42. 

  42.             ids  = sd1  ; ide  = ed1  ; jds  = sd2  ; jde  = ed2  ; kds  = sd3  ; kde  = ed3
    43. 

  43.             ips  = sp1  ; ipe  = ep1  ; jps  = sp2  ; jpe  = ep2  ; kps  = sp3  ; kpe  = ep3
    44. 

  44.             ims  = sm1  ; ime  = em1  ; jms  = sm2  ; jme  = em2  ; kms  = sm3  ; kme  = em3
    45. 

  45.             ipsx = sp1x ; ipex = ep1x ; jpsx = sp2x ; jpex = ep2x ; kpsx = sp3x ; kpex = ep3x
    46. 

  46.             imsx = sm1x ; imex = em1x ; jmsx = sm2x ; jmex = em2x ; kmsx = sm3x ; kmex = em3x
    47. 

  47.           CASE ( DATA_ORDER_YXZ )
    48. 

  48.             ids  = sd2  ; ide  = ed2  ; jds  = sd1  ; jde  = ed1  ; kds  = sd3  ; kde  = ed3
    49. 

  49.             ips  = sp2  ; ipe  = ep2  ; jps  = sp1  ; jpe  = ep1  ; kps  = sp3  ; kpe  = ep3
    50. 

  50.             ims  = sm2  ; ime  = em2  ; jms  = sm1  ; jme  = em1  ; kms  = sm3  ; kme  = em3
    51. 

  51.             ipsx = sp2x ; ipex = ep2x ; jpsx = sp1x ; jpex = ep1x ; kpsx = sp3x ; kpex = ep3x
    52. 

  52.             imsx = sm2x ; imex = em2x ; jmsx = sm1x ; jmex = em1x ; kmsx = sm3x ; kmex = em3x
    53. 

  53.           CASE ( DATA_ORDER_XZY )
    54. 

  54.             ids  = sd1  ; ide  = ed1  ; jds  = sd3  ; jde  = ed3  ; kds  = sd2  ; kde  = ed2
    55. 

  55.             ips  = sp1  ; ipe  = ep1  ; jps  = sp3  ; jpe  = ep3  ; kps  = sp2  ; kpe  = ep2
    56. 

  56.             ims  = sm1  ; ime  = em1  ; jms  = sm3  ; jme  = em3  ; kms  = sm2  ; kme  = em2
    57. 

  57.             ipsx = sp1x ; ipex = ep1x ; jpsx = sp3x ; jpex = ep3x ; kpsx = sp2x ; kpex = ep2x
    58. 

  58.             imsx = sm1x ; imex = em1x ; jmsx = sm3x ; jmex = em3x ; kmsx = sm2x ; kmex = em2x
    59. 

  59.           CASE ( DATA_ORDER_YZX )
    60. 

  60.             ids  = sd3  ; ide  = ed3  ; jds  = sd1  ; jde  = ed1  ; kds  = sd2  ; kde  = ed2
    61. 

  61.             ips  = sp3  ; ipe  = ep3  ; jps  = sp1  ; jpe  = ep1  ; kps  = sp2  ; kpe  = ep2
    62. 

  62.             ims  = sm3  ; ime  = em3  ; jms  = sm1  ; jme  = em1  ; kms  = sm2  ; kme  = em2
    63. 

  63.             ipsx = sp3x ; ipex = ep3x ; jpsx = sp1x ; jpex = ep1x ; kpsx = sp2x ; kpex = ep2x
    64. 

  64.             imsx = sm3x ; imex = em3x ; jmsx = sm1x ; jmex = em1x ; kmsx = sm2x ; kmex = em2x
    65. 

  65.           CASE ( DATA_ORDER_ZXY )
    66. 

  66.             ids  = sd2  ; ide  = ed2  ; jds  = sd3  ; jde  = ed3  ; kds  = sd1  ; kde  = ed1
    67. 

  67.             ips  = sp2  ; ipe  = ep2  ; jps  = sp3  ; jpe  = ep3  ; kps  = sp1  ; kpe  = ep1
    68. 

  68.             ims  = sm2  ; ime  = em2  ; jms  = sm3  ; jme  = em3  ; kms  = sm1  ; kme  = em1
    69. 

  69.             ipsx = sp2x ; ipex = ep2x ; jpsx = sp3x ; jpex = ep3x ; kpsx = sp1x ; kpex = ep1x
    70. 

  70.             imsx = sm2x ; imex = em2x ; jmsx = sm3x ; jmex = em3x ; kmsx = sm1x ; kmex = em1x
    71. 

  71.           CASE ( DATA_ORDER_ZYX )
    72. 

  72.             ids  = sd3  ; ide  = ed3  ; jds  = sd2  ; jde  = ed2  ; kds  = sd1  ; kde  = ed1
    73. 

  73.             ips  = sp3  ; ipe  = ep3  ; jps  = sp2  ; jpe  = ep2  ; kps  = sp1  ; kpe  = ep1
    74. 

  74.             ims  = sm3  ; ime  = em3  ; jms  = sm2  ; jme  = em2  ; kms  = sm1  ; kme  = em1
    75. 

  75.             ipsx = sp3x ; ipex = ep3x ; jpsx = sp2x ; jpex = ep2x ; kpsx = sp1x ; kpex = ep1x
    76. 

  76.             imsx = sm3x ; imex = em3x ; jmsx = sm2x ; jmex = em2x ; kmsx = sm1x ; kmex = em1x
    77. 

  77.          END SELECT
    78. 

  78. 

  79.          sendcnts = 0 ; recvcnts = 0
    80. 

  80. 

  81.          xbuf = 0 
    82. 

  82.          zbuf = 0 
    83. 

  83. 

  84. ! work out send/recv sizes to each processor in X dimension
    85. 

  85.          pencil(1) = ips 
    86. 

  86.          pencil(2) = ipe 
    87. 

  87.          pencil(3) = kpsx
    88. 

  88.          pencil(4) = kpex
    89. 

  89.          call mpi_allgather( pencil, 4, MPI_INTEGER, allpencils, 4, MPI_INTEGER, comm, ierr )
    90. 

  90.          do p = 1, np
    91. 

  91.            is(p) = allpencils(1,p)
    92. 

  92.            ie(p) = allpencils(2,p)
    93. 

  93.            ks(p) = allpencils(3,p)
    94. 

  94.            ke(p) = allpencils(4,p)
    95. 

  95.          enddo
    96. 

  96. ! pack send buffer
    97. 

  97.          sendcurs = 0 
    98. 

  98.          sdispls = 0
    99. 

  99.          sc = 0
    100. 

  100.          do p = 1, np
    101. 

  101.            if ( r_wordsize .eq. i_wordsize ) then
    102. 

  102.              if ( dir .eq. 1 ) then
    103. 

  103.                call f_pack_int ( a, zbuf(sc), memorder,                                     &
    104. 

  104.      &                                        jps, jpe, ks(p), ke(p), ips, ipe,             &
    105. 

  105.      &                                        jms, jme, kms, kme, ims, ime, sendcurs(p) )
    106. 

  106.              else
    107. 

  107.                call f_pack_int ( ax, xbuf(sc), memorder,                                    &
    108. 

  108.      &                                        jpsx, jpex, kpsx, kpex, is(p), ie(p),         &
    109. 

  109.      &                                        jmsx, jmex, kmsx, kmex, imsx, imex, sendcurs(p) )
    110. 

  110.              endif
    111. 

  111.            else if ( r_wordsize .eq. 8 ) THEN
    112. 

  112.              if ( dir .eq. 1 ) then
    113. 

  113.                call f_pack_lint ( a, zbuf(sc), memorder,                                    &
    114. 

  114.      &                                        jps, jpe, ks(p), ke(p), ips, ipe,             &
    115. 

  115.      &                                        jms, jme, kms, kme, ims, ime, sendcurs(p) )
    116. 

  116.              else
    117. 

  117.                call f_pack_lint ( ax, xbuf(sc), memorder,                                   &
    118. 

  118.      &                                        jpsx, jpex, kpsx, kpex, is(p), ie(p),         &
    119. 

  119.      &                                        jmsx, jmex, kmsx, kmex, imsx, imex, sendcurs(p) )
    120. 

  120.              endif
    121. 

  121.              sendcurs(p) = sendcurs(p) * max(1,(r_wordsize/i_wordsize)) 
    122. 

  122.            else
    123. 

  123.              write(0,*)'RSL_LITE internal error: type size mismatch ',__FILE__,__LINE__
    124. 

  124.              call mpi_abort(ierr)
    125. 

  125.            endif
    126. 

  126.            sc = sc + sendcurs(p)
    127. 

  127.            sendcnts(p) = sendcurs(p)
    128. 

  128.            if ( p .GT. 1 ) sdispls(p) = sdispls(p-1) + sendcnts(p-1)
    129. 

  129.          enddo
    130. 

  130. ! work out receive counts and displs
    131. 

  131.          rdispls = 0
    132. 

  132.          recvcnts = 0
    133. 

  133.          do p = 1, np
    134. 

  134.            if ( dir .eq. 1 ) then
    135. 

  135.              recvcnts(p) = (ie(p)-is(p)+1)*(kpex-kpsx+1)*(jpex-jpsx+1) * max(1,(r_wordsize/i_wordsize))
    136. 

  136.            else
    137. 

  137.              recvcnts(p) = (ke(p)-ks(p)+1)*(ipe-ips+1)*(jpe-jps+1) * max(1,(r_wordsize/i_wordsize))
    138. 

  138.            endif
    139. 

  139.            if ( p .GT. 1 ) rdispls(p) = rdispls(p-1) + recvcnts(p-1)
    140. 

  140.          enddo
    141. 

  141. ! do the transpose
    142. 

  142.          if ( dir .eq. 1 ) then
    143. 

  143.            call mpi_alltoallv(zbuf, sendcnts, sdispls, MPI_INTEGER,              &
    144. 

  144.                               xbuf, recvcnts, rdispls, MPI_INTEGER, comm, ierr )
    145. 

  145.          else
    146. 

  146.            call mpi_alltoallv(xbuf, sendcnts, sdispls, MPI_INTEGER,              &
    147. 

  147.                               zbuf, recvcnts, rdispls, MPI_INTEGER, comm, ierr )
    148. 

  148.          endif
    149. 

  149. ! unpack
    150. 

  150.          do p = 1, np
    151. 

  151.            if ( r_wordsize .eq. i_wordsize ) then
    152. 

  152.              if ( dir .eq. 1 ) then
    153. 

  153.                call f_unpack_int ( xbuf(rdispls(p)), ax, memorder,                        &
    154. 

  154.      &                                        jpsx, jpex, kpsx, kpex, is(p), ie(p),       &
    155. 

  155.      &                                        jmsx, jmex, kmsx, kmex, imsx, imex, curs )
    156. 

  156.              else
    157. 

  157.                call f_unpack_int ( zbuf(rdispls(p)), a, memorder,                         &
    158. 

  158.      &                                        jps, jpe, ks(p), ke(p), ips, ipe,           &
    159. 

  159.      &                                        jms, jme, kms, kme, ims, ime, curs )
    160. 

  160.              endif
    161. 

  161.            else if ( r_wordsize .eq. 8 ) THEN
    162. 

  162.              if ( dir .eq. 1 ) then
    163. 

  163.                call f_unpack_lint ( xbuf(rdispls(p)), ax, memorder,                       &
    164. 

  164.      &                                        jpsx, jpex, kpsx, kpex, is(p), ie(p),       &
    165. 

  165.      &                                        jmsx, jmex, kmsx, kmex, imsx, imex, curs )
    166. 

  166.              else
    167. 

  167.                call f_unpack_lint ( zbuf(rdispls(p)), a, memorder,                        &
    168. 

  168.      &                                        jps, jpe, ks(p), ke(p), ips, ipe,           &
    169. 

  169.      &                                        jms, jme, kms, kme, ims, ime, curs )
    170. 

  170.              endif
    171. 

  171.            else
    172. 

  172.              write(0,*)'RSL_LITE internal error: type size mismatch ',__FILE__,__LINE__
    173. 

  173.              call mpi_abort(ierr)
    174. 

  174.            endif
    175. 

  175.          enddo
    176. 

  176. #endif
    177. 

  177.          return
    178. 

  178.       end subroutine trans_z2x
    179. 

  179. 

  180.       subroutine trans_x2y ( np, comm, dir, r_wordsize, i_wordsize, memorder, &
    181. 

  181.                                ax, &
    182. 

  182.                                sd1, ed1, sd2, ed2, sd3, ed3, &
    183. 

  183.                                sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
    184. 

  184.                                sm1x, em1x, sm2x, em2x, sm3x, em3x, &
    185. 

  185.                                ay, &
    186. 

  186.                                sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
    187. 

  187.                                sm1y, em1y, sm2y, em2y, sm3y, em3y )
    188. 

  188.          USE duplicate_of_driver_constants
    189. 

  189.          implicit none
    190. 

  190.          integer, intent(in) :: memorder
    191. 

  191.          integer, intent(in) ::  sd1, ed1, sd2, ed2, sd3, ed3, &
    192. 

  192.                                  sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
    193. 

  193.                                  sm1x, em1x, sm2x, em2x, sm3x, em3x, &
    194. 

  194.                                  sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
    195. 

  195.                                  sm1y, em1y, sm2y, em2y, sm3y, em3y
    196. 

  196. 

  197.          integer, intent(in) :: np, comm, r_wordsize, i_wordsize
    198. 

  198.          integer, intent(in) :: dir ! 1 is a->ax, otherwise ax->a
    199. 

  199.          integer, dimension((ep1x-sp1x+1)*(ep2x-ep2x+1)*(ep3x-sp3x+1)*max(1,(r_wordsize/i_wordsize)))   :: ax
    200. 

  200.          integer, dimension((ep1y-sp1y+1)*(ep2y-sp2y+1)*(ep3y-sp3y+1)*max(1,(r_wordsize/i_wordsize)))   :: ay
    201. 

  201. #ifndef STUBMPI
    202. 

  202.          include 'mpif.h'
    203. 

  203. 

  204.          integer, dimension(0:(ep1x-sp1x+1)*(ep2x-sp2x+1)*(ep3x-sp3x+1)*max(1,(r_wordsize/i_wordsize))) :: xbuf
    205. 

  205.          integer, dimension(0:(ep1y-sp1y+1)*(ep2y-sp2y+1)*(ep3y-sp3y+1)*max(1,(r_wordsize/i_wordsize))) :: ybuf
    206. 

  206. 

  207. !local
    208. 

  208.          integer              ids, ide, jds, jde, kds, kde, & 
    209. 

  209.                               ipsx, ipex, jpsx, jpex, kpsx, kpex, & 
    210. 

  210.                               imsx, imex, jmsx, jmex, kmsx, kmex, &
    211. 

  211.                               ipsy, ipey, jpsy, jpey, kpsy, kpey, & 
    212. 

  212.                               imsy, imey, jmsy, jmey, kmsy, kmey
    213. 

  213.          integer pencil(4), allpencils(4,np)
    214. 

  214.          integer sendcnts(np), sdispls(np), recvcnts(np), rdispls(np)
    215. 

  215.          integer allsendcnts(np+2,np), is(np), ie(np), js(np), je(np)
    216. 

  216.          integer sendcurs(np), recvcurs(np)
    217. 

  217.          integer i,j,k,p,sc,sp,rp,yp,zp,curs,xbufsz,cells,nkcells,ivectype,ierr
    218. 

  218. 

  219.          SELECT CASE ( memorder )
    220. 

  220.           CASE ( DATA_ORDER_XYZ )
    221. 

  221.             ids  = sd1  ; ide  = ed1  ; jds  = sd2  ; jde  = ed2  ; kds  = sd3  ; kde  = ed3
    222. 

  222.             ipsx = sp1x ; ipex = ep1x ; jpsx = sp2x ; jpex = ep2x ; kpsx = sp3x ; kpex = ep3x
    223. 

  223.             imsx = sm1x ; imex = em1x ; jmsx = sm2x ; jmex = em2x ; kmsx = sm3x ; kmex = em3x
    224. 

  224.             ipsy = sp1y ; ipey = ep1y ; jpsy = sp2y ; jpey = ep2y ; kpsy = sp3y ; kpey = ep3y
    225. 

  225.             imsy = sm1y ; imey = em1y ; jmsy = sm2y ; jmey = em2y ; kmsy = sm3y ; kmey = em3y
    226. 

  226.           CASE ( DATA_ORDER_YXZ )
    227. 

  227.             ids  = sd2  ; ide  = ed2  ; jds  = sd1  ; jde  = ed1  ; kds  = sd3  ; kde  = ed3
    228. 

  228.             ipsx = sp2x ; ipex = ep2x ; jpsx = sp1x ; jpex = ep1x ; kpsx = sp3x ; kpex = ep3x
    229. 

  229.             imsx = sm2x ; imex = em2x ; jmsx = sm1x ; jmex = em1x ; kmsx = sm3x ; kmex = em3x
    230. 

  230.             ipsy = sp2y ; ipey = ep2y ; jpsy = sp1y ; jpey = ep1y ; kpsy = sp3y ; kpey = ep3y
    231. 

  231.             imsy = sm2y ; imey = em2y ; jmsy = sm1y ; jmey = em1y ; kmsy = sm3y ; kmey = em3y
    232. 

  232.           CASE ( DATA_ORDER_XZY )
    233. 

  233.             ids  = sd1  ; ide  = ed1  ; jds  = sd3  ; jde  = ed3  ; kds  = sd2  ; kde  = ed2
    234. 

  234.             ipsx = sp1x ; ipex = ep1x ; jpsx = sp3x ; jpex = ep3x ; kpsx = sp2x ; kpex = ep2x
    235. 

  235.             imsx = sm1x ; imex = em1x ; jmsx = sm3x ; jmex = em3x ; kmsx = sm2x ; kmex = em2x
    236. 

  236.             ipsy = sp1y ; ipey = ep1y ; jpsy = sp3y ; jpey = ep3y ; kpsy = sp2y ; kpey = ep2y
    237. 

  237.             imsy = sm1y ; imey = em1y ; jmsy = sm3y ; jmey = em3y ; kmsy = sm2y ; kmey = em2y
    238. 

  238.           CASE ( DATA_ORDER_YZX )
    239. 

  239.             ids  = sd3  ; ide  = ed3  ; jds  = sd1  ; jde  = ed1  ; kds  = sd2  ; kde  = ed2
    240. 

  240.             ipsx = sp3x ; ipex = ep3x ; jpsx = sp1x ; jpex = ep1x ; kpsx = sp2x ; kpex = ep2x
    241. 

  241.             imsx = sm3x ; imex = em3x ; jmsx = sm1x ; jmex = em1x ; kmsx = sm2x ; kmex = em2x
    242. 

  242.             ipsy = sp3y ; ipey = ep3y ; jpsy = sp1y ; jpey = ep1y ; kpsy = sp2y ; kpey = ep2y
    243. 

  243.             imsy = sm3y ; imey = em3y ; jmsy = sm1y ; jmey = em1y ; kmsy = sm2y ; kmey = em2y
    244. 

  244.           CASE ( DATA_ORDER_ZXY )
    245. 

  245.             ids  = sd2  ; ide  = ed2  ; jds  = sd3  ; jde  = ed3  ; kds  = sd1  ; kde  = ed1
    246. 

  246.             ipsx = sp2x ; ipex = ep2x ; jpsx = sp3x ; jpex = ep3x ; kpsx = sp1x ; kpex = ep1x
    247. 

  247.             imsx = sm2x ; imex = em2x ; jmsx = sm3x ; jmex = em3x ; kmsx = sm1x ; kmex = em1x
    248. 

  248.             ipsy = sp2y ; ipey = ep2y ; jpsy = sp3y ; jpey = ep3y ; kpsy = sp1y ; kpey = ep1y
    249. 

  249.             imsy = sm2y ; imey = em2y ; jmsy = sm3y ; jmey = em3y ; kmsy = sm1y ; kmey = em1y
    250. 

  250.           CASE ( DATA_ORDER_ZYX )
    251. 

  251.             ids  = sd3  ; ide  = ed3  ; jds  = sd2  ; jde  = ed2  ; kds  = sd1  ; kde  = ed1
    252. 

  252.             ipsx = sp3x ; ipex = ep3x ; jpsx = sp2x ; jpex = ep2x ; kpsx = sp1x ; kpex = ep1x
    253. 

  253.             imsx = sm3x ; imex = em3x ; jmsx = sm2x ; jmex = em2x ; kmsx = sm1x ; kmex = em1x
    254. 

  254.             ipsy = sp3y ; ipey = ep3y ; jpsy = sp2y ; jpey = ep2y ; kpsy = sp1y ; kpey = ep1y
    255. 

  255.             imsy = sm3y ; imey = em3y ; jmsy = sm2y ; jmey = em2y ; kmsy = sm1y ; kmey = em1y
    256. 

  256.          END SELECT
    257. 

  257. 

  258.          sendcnts = 0 ; recvcnts = 0
    259. 

  259. 

  260.          xbuf = 0 
    261. 

  261.          ybuf = 0 
    262. 

  262. 

  263. ! work out send/recv sizes to each processor in X dimension
    264. 

  264.          pencil(1) = jpsx
    265. 

  265.          pencil(2) = jpex
    266. 

  266.          pencil(3) = ipsy
    267. 

  267.          pencil(4) = ipey
    268. 

  268. 

  269.          call mpi_allgather( pencil, 4, MPI_INTEGER, allpencils, 4, MPI_INTEGER, comm, ierr )
    270. 

  270.          do p = 1, np
    271. 

  271.            js(p) = allpencils(1,p)
    272. 

  272.            je(p) = allpencils(2,p)
    273. 

  273.            is(p) = allpencils(3,p)
    274. 

  274.            ie(p) = allpencils(4,p)
    275. 

  275.          enddo
    276. 

  276. 

  277. 

  278. ! pack send buffer
    279. 

  279.          sendcurs = 0 
    280. 

  280.          sdispls = 0
    281. 

  281.          sc = 0
    282. 

  282.          do p = 1, np
    283. 

  283.            if ( r_wordsize .eq. i_wordsize ) then
    284. 

  284.              if ( dir .eq. 1 ) then
    285. 

  285.                call f_pack_int ( ax, xbuf(sc), memorder,                                    &
    286. 

  286.      &                                         jpsx, jpex, kpsx, kpex, is(p), ie(p),        &
    287. 

  287.      &                                         jmsx, jmex, kmsx, kmex, imsx, imex, sendcurs(p) )
    288. 

  288.              else
    289. 

  289.                call f_pack_int ( ay, ybuf(sc), memorder,                                    &
    290. 

  290.      &                                         js(p), je(p), kpsy, kpey, ipsy, ipey,        &
    291. 

  291.      &                                         jmsy, jmey, kmsy, kmey, imsy, imey, sendcurs(p) )
    292. 

  292.              endif
    293. 

  293.            else if ( r_wordsize .eq. 8 ) THEN
    294. 

  294.              if ( dir .eq. 1 ) then
    295. 

  295.                call f_pack_lint ( ax, xbuf(sc), memorder,                                    &
    296. 

  296.      &                                          jpsx, jpex, kpsx, kpex, is(p), ie(p),        &
    297. 

  297.      &                                          jmsx, jmex, kmsx, kmex, imsx, imex, sendcurs(p) )
    298. 

  298.              else
    299. 

  299.                call f_pack_lint ( ay, ybuf(sc), memorder,                                    &
    300. 

  300.      &                                          js(p), je(p), kpsy, kpey, ipsy, ipey,        &
    301. 

  301.      &                                          jmsy, jmey, kmsy, kmey, imsy, imey, sendcurs(p) )
    302. 

  302.              endif
    303. 

  303.              sendcurs(p) = sendcurs(p) * max(1,(r_wordsize/i_wordsize)) 
    304. 

  304.            else
    305. 

  305.              write(0,*)'RSL_LITE internal error: type size mismatch ',__FILE__,__LINE__
    306. 

  306.              call mpi_abort(ierr)
    307. 

  307.            endif
    308. 

  308.            sc = sc + sendcurs(p)
    309. 

  309.            sendcnts(p) = sendcurs(p)
    310. 

  310.            if ( p .GT. 1 ) sdispls(p) = sdispls(p-1) + sendcnts(p-1)
    311. 

  311.          enddo
    312. 

  312. 

  313. ! work out receive counts and displs
    314. 

  314.          rdispls = 0
    315. 

  315.          recvcnts = 0
    316. 

  316.          do p = 1, np
    317. 

  317.            if ( dir .eq. 1 ) then
    318. 

  318.              recvcnts(p) = (je(p)-js(p)+1)*(kpey-kpsy+1)*(ipey-ipsy+1) * max(1,(r_wordsize/i_wordsize))
    319. 

  319.            else
    320. 

  320.              recvcnts(p) = (ie(p)-is(p)+1)*(kpex-kpsx+1)*(jpex-jpsx+1) * max(1,(r_wordsize/i_wordsize))
    321. 

  321.            endif
    322. 

  322.            if ( p .GT. 1 ) rdispls(p) = rdispls(p-1) + recvcnts(p-1)
    323. 

  323.          enddo
    324. 

  324. 

  325. ! do the transpose
    326. 

  326.          if ( dir .eq. 1 ) then
    327. 

  327.            call mpi_alltoallv(xbuf, sendcnts, sdispls, MPI_INTEGER,              &
    328. 

  328.                               ybuf, recvcnts, rdispls, MPI_INTEGER, comm, ierr )
    329. 

  329.          else
    330. 

  330.            call mpi_alltoallv(ybuf, sendcnts, sdispls, MPI_INTEGER,              &
    331. 

  331.                               xbuf, recvcnts, rdispls, MPI_INTEGER, comm, ierr )
    332. 

  332.          endif
    333. 

  333. ! unpack
    334. 

  334.          do p = 1, np
    335. 

  335.            if ( r_wordsize .eq. i_wordsize ) then
    336. 

  336.              if ( dir .eq. 1 ) then
    337. 

  337.                call f_unpack_int ( ybuf(rdispls(p)), ay, memorder,                                  &
    338. 

  338.      &                                                   js(p), je(p), kpsy, kpey, ipsy, ipey,      &
    339. 

  339.      &                                                   jmsy, jmey, kmsy, kmey, imsy, imey, curs )
    340. 

  340.              else
    341. 

  341.                call f_unpack_int ( xbuf(rdispls(p)), ax, memorder,                                  &
    342. 

  342.      &                                                   jpsx, jpex, kpsx, kpex, is(p), ie(p),      &
    343. 

  343.      &                                                   jmsx, jmex, kmsx, kmex, imsx, imex, curs )
    344. 

  344.              endif
    345. 

  345.            else if ( r_wordsize .eq. 8 ) THEN
    346. 

  346.              if ( dir .eq. 1 ) then
    347. 

  347.                call f_unpack_lint ( ybuf(rdispls(p)), ay, memorder,                                 &
    348. 

  348.      &                                                    js(p), je(p), kpsy, kpey, ipsy, ipey,     &
    349. 

  349.      &                                                    jmsy, jmey, kmsy, kmey, imsy, imey, curs )
    350. 

  350.              else
    351. 

  351.                call f_unpack_lint ( xbuf(rdispls(p)), ax, memorder,                                 &
    352. 

  352.      &                                                    jpsx, jpex, kpsx, kpex, is(p), ie(p),     &
    353. 

  353.      &                                                    jmsx, jmex, kmsx, kmex, imsx, imex, curs )
    354. 

  354.              endif
    355. 

  355.            else
    356. 

  356.              write(0,*)'RSL_LITE internal error: type size mismatch ',__FILE__,__LINE__
    357. 

  357.              call mpi_abort(ierr)
    358. 

  358.            endif
    359. 

  359.          enddo
    360. 

  360. #endif
    361. 

  361.          return
    362. 

  362.       end subroutine trans_x2y
    363. 

  363. 

  364.