Changeset 51 for trunk/NEMO/OPA_SRC/lib_mpp.F90
- Timestamp:
- 2004-04-22T11:38:52+02:00 (20 years ago)
- File:
-
- 1 edited
-
trunk/NEMO/OPA_SRC/lib_mpp.F90 (modified) (25 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/OPA_SRC/lib_mpp.F90
r13 r51 68 68 END INTERFACE 69 69 70 !! * Module parameters70 !! * Share module variables 71 71 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag 72 72 73 !! The processor number is a required power of two : 74 !! 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,... 75 !! MPP dimension 76 INTEGER, PARAMETER :: & 77 nprocmax = 2**10, & ! maximun dimension 78 ndim_mpp = jpnij ! dimension for this simulation 79 80 !! No MPI variable definition 81 # if defined key_mpp_shmem 82 !! * PVM and SHMEM version 83 CHARACTER (len=80), PARAMETER :: simfile = 'pvm3_ndim' ! file name 84 CHARACTER (len=47), PARAMETER :: executable = 'opa' ! executable name 85 CHARACTER, PARAMETER :: opaall = "" ! group name (old def opaall*(*)) 86 87 !! PVM control 88 INTEGER, PARAMETER :: & 89 mynode_print = 0, & ! flag for print, mynode routine 90 mpprecv_print = 0, & ! flag for print, mpprecv routine 91 mppsend_print = 0, & ! flag for print, mppsend routine 92 mppsync_print = 0, & ! flag for print, mppsync routine 93 mppsum_print = 0, & ! flag for print, mpp_sum routine 94 mppisl_print = 0, & ! flag for print, mpp_isl routine 95 mppmin_print = 0, & ! flag for print, mpp_min routine 96 mppmax_print = 0, & ! flag for print, mpp_max routine 97 mpparent_print = 0 ! flag for print, mpparent routine 98 99 !! Variable definition 100 INTEGER, PARAMETER :: & 101 jpvmreal = 6, & ! ??? 102 jpvmint = 21 ! ??? 103 104 ! Maximum dimension of array to sum on the processors 105 INTEGER, PARAMETER :: & !!! SHMEM case 106 jpmsec = 50000, & ! ??? 107 jpmpplat = 30, & ! ??? 108 jpmppsum = MAX( jpisl*jpisl, jpmpplat*jpk, jpmsec ) 109 ! ! ??? 110 # endif 111 112 113 !! * Module variables 73 74 !! * Module variables 75 !! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,... 76 INTEGER, PARAMETER :: & 77 nprocmax = 2**10, & ! maximun dimension 78 ndim_mpp = jpnij ! dimension for this simulation 114 79 115 80 #if defined key_mpp_mpi 116 !! * MPI variable definition 81 !! ========================= !! 82 !! MPI variable definition !! 83 !! ========================= !! 117 84 # include <mpif.h> 118 85 119 INTEGER :: & 120 size, & ! number of process 121 rank ! process number [ 0 - size-1 ] 86 INTEGER :: & 87 size, & ! number of process 88 rank ! process number [ 0 - size-1 ] 89 90 ! variables used in case of north fold condition in mpp_mpi with jpni > 1 91 INTEGER :: & ! 92 ngrp_world, & ! group ID for the world processors 93 ngrp_north, & ! group ID for the northern processors (to be fold) 94 ncomm_north, & ! communicator made by the processors belonging to ngrp_north 95 ndim_rank_north, & ! number of 'sea' processor in the northern line (can be /= jpni !) 96 njmppmax ! value of njmpp for the processors of the northern line 97 INTEGER :: & ! 98 north_root ! number (in the comm_world) of proc 0 in the northern comm 99 INTEGER, DIMENSION(:), ALLOCATABLE :: & 100 nrank_north ! dimension ndim_rank_north, number of the procs belonging to ncomm_north 101 102 122 103 #elif defined key_mpp_shmem 123 !! * SHMEM version 104 !! ========================= !! 105 !! SHMEM variable definition !! 106 !! ========================= !! 124 107 # include <fpvm3.h> 125 126 !! * PVM variable definition127 INTEGER :: &128 npvm_ipas , & ! pvm initialization flag129 npvm_mytid, & ! pvm tid130 npvm_me , & ! node number [ 0 - nproc-1 ]131 npvm_nproc, & ! real number of nodes132 npvm_inum ! ???133 INTEGER, DIMENSION(0:nprocmax-1) :: &134 npvm_tids ! tids array [ 0 - nproc-1 ]135 136 !! T3D variable definition137 INTEGER :: &138 nt3d_ipas , & ! pvm initialization flag139 nt3d_mytid, & ! pvm tid140 nt3d_me , & ! node number [ 0 - nproc-1 ]141 nt3d_nproc ! real number of nodes142 INTEGER, DIMENSION(0:nprocmax-1) :: &143 nt3d_tids ! tids array [ 0 - nproc-1 ]144 145 !! * SHMEM version146 108 # include <mpp/shmem.fh> 147 109 148 !! real sum reduction 149 INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: & 110 CHARACTER (len=80), PARAMETER :: simfile = 'pvm3_ndim' ! file name 111 CHARACTER (len=47), PARAMETER :: executable = 'opa' ! executable name 112 CHARACTER, PARAMETER :: opaall = "" ! group name (old def opaall*(*)) 113 114 INTEGER, PARAMETER :: & !! SHMEM control print 115 mynode_print = 0, & ! flag for print, mynode routine 116 mpprecv_print = 0, & ! flag for print, mpprecv routine 117 mppsend_print = 0, & ! flag for print, mppsend routine 118 mppsync_print = 0, & ! flag for print, mppsync routine 119 mppsum_print = 0, & ! flag for print, mpp_sum routine 120 mppisl_print = 0, & ! flag for print, mpp_isl routine 121 mppmin_print = 0, & ! flag for print, mpp_min routine 122 mppmax_print = 0, & ! flag for print, mpp_max routine 123 mpparent_print = 0 ! flag for print, mpparent routine 124 125 INTEGER, PARAMETER :: & !! Variable definition 126 jpvmint = 21 ! ??? 127 128 INTEGER, PARAMETER :: & !! Maximum dimension of array to sum on the processors 129 jpmsec = 50000, & ! ??? 130 jpmpplat = 30, & ! ??? 131 jpmppsum = MAX( jpisl*jpisl, jpmpplat*jpk, jpmsec ) ! ??? 132 133 INTEGER :: & 134 npvm_ipas , & ! pvm initialization flag 135 npvm_mytid, & ! pvm tid 136 npvm_me , & ! node number [ 0 - nproc-1 ] 137 npvm_nproc, & ! real number of nodes 138 npvm_inum ! ??? 139 INTEGER, DIMENSION(0:nprocmax-1) :: & 140 npvm_tids ! tids array [ 0 - nproc-1 ] 141 142 INTEGER :: & 143 nt3d_ipas , & ! pvm initialization flag 144 nt3d_mytid, & ! pvm tid 145 nt3d_me , & ! node number [ 0 - nproc-1 ] 146 nt3d_nproc ! real number of nodes 147 INTEGER, DIMENSION(0:nprocmax-1) :: & 148 nt3d_tids ! tids array [ 0 - nproc-1 ] 149 150 !! real sum reduction 151 INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: & 150 152 nrs1sync_shmem, & ! 151 153 nrs2sync_shmem 152 REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &154 REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: & 153 155 wrs1wrk_shmem, & ! 154 156 wrs2wrk_shmem ! 155 REAL(wp), DIMENSION(jpmppsum) :: wrstab_shmem 156 157 !! minimum and maximum reduction 158 INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: & 157 REAL(wp), DIMENSION(jpmppsum) :: & 158 wrstab_shmem ! 159 160 !! minimum and maximum reduction 161 INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: & 159 162 ni1sync_shmem, & ! 160 163 ni2sync_shmem ! 161 REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &162 wi1wrk_shmem 163 wi2wrk_shmem164 REAL(wp), DIMENSION(jpmppsum) :: &164 REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: & 165 wi1wrk_shmem, & ! 166 wi2wrk_shmem 167 REAL(wp), DIMENSION(jpmppsum) :: & 165 168 wintab_shmem, & ! 166 169 wi1tab_shmem, & ! 167 wi2tab_shmem &!170 wi2tab_shmem ! 168 171 169 172 !! value not equal zero for barotropic stream function around islands 170 INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &173 INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: & 171 174 ni11sync_shmem, & ! 172 175 ni12sync_shmem, & ! 173 176 ni21sync_shmem, & ! 174 177 ni22sync_shmem ! 175 REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &178 REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: & 176 179 wi11wrk_shmem, & ! 177 180 wi12wrk_shmem, & ! 178 181 wi21wrk_shmem, & ! 179 182 wi22wrk_shmem ! 180 REAL(wp), DIMENSION(jpmppsum) :: &183 REAL(wp), DIMENSION(jpmppsum) :: & 181 184 wiltab_shmem , & ! 182 185 wi11tab_shmem, & ! … … 185 188 wi22tab_shmem 186 189 187 INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &190 INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: & 188 191 ni11wrk_shmem, & ! 189 192 ni12wrk_shmem, & ! 190 193 ni21wrk_shmem, & ! 191 194 ni22wrk_shmem ! 192 INTEGER, DIMENSION(jpmppsum) :: &195 INTEGER, DIMENSION(jpmppsum) :: & 193 196 niitab_shmem , & ! 194 197 ni11tab_shmem, & ! 195 198 ni12tab_shmem ! 196 INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &199 INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: & 197 200 nis1sync_shmem, & ! 198 201 nis2sync_shmem ! 199 INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &202 INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: & 200 203 nis1wrk_shmem, & ! 201 204 nis2wrk_shmem ! 202 INTEGER, DIMENSION(jpmppsum) :: &205 INTEGER, DIMENSION(jpmppsum) :: & 203 206 nistab_shmem 204 207 205 !! integer sum reduction206 INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &208 !! integer sum reduction 209 INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: & 207 210 nil1sync_shmem, & ! 208 211 nil2sync_shmem ! 209 INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &212 INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: & 210 213 nil1wrk_shmem, & ! 211 214 nil2wrk_shmem ! 212 INTEGER, DIMENSION(jpmppsum) :: &215 INTEGER, DIMENSION(jpmppsum) :: & 213 216 niltab_shmem 214 215 #endif 216 #if defined key_mpp_mpi 217 ! variables used in case of north fold condition in mpp_mpi with jpni > 1 218 INTEGER :: & ! 219 ngrp_world, & ! group ID for the world processors 220 ngrp_north, & ! group ID for the northern processors (to be fold) 221 ncomm_north, & ! communicator made by the processors belonging to ngrp_north 222 ndim_rank_north, & ! number of 'sea' processor in the northern line (can be /= jpni !) 223 njmppmax ! value of njmpp for the processors of the northern line 224 INTEGER :: & ! 225 north_root ! number (in the comm_world) of proc 0 in the northern comm 226 INTEGER, DIMENSION(:), ALLOCATABLE :: & 227 nrank_north ! dimension ndim_rank_north, number of the procs belonging to ncomm_north 228 #endif 229 230 REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: & 217 #endif 218 219 REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: & 231 220 t3ns, t3sn ! 3d message passing arrays north-south & south-north 232 REAL(wp), DIMENSION(jpj,jpreci,jpk,2) :: &221 REAL(wp), DIMENSION(jpj,jpreci,jpk,2) :: & 233 222 t3ew, t3we ! 3d message passing arrays east-west & west-east 234 REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: &223 REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: & 235 224 t3p1, t3p2 ! 3d message passing arrays north fold 236 REAL(wp), DIMENSION(jpi,jprecj,2) :: &225 REAL(wp), DIMENSION(jpi,jprecj,2) :: & 237 226 t2ns, t2sn ! 2d message passing arrays north-south & south-north 238 REAL(wp), DIMENSION(jpj,jpreci,2) :: &227 REAL(wp), DIMENSION(jpj,jpreci,2) :: & 239 228 t2ew, t2we ! 2d message passing arrays east-west & west-east 240 REAL(wp), DIMENSION(jpi,jprecj,2) :: &229 REAL(wp), DIMENSION(jpi,jprecj,2) :: & 241 230 t2p1, t2p2 ! 2d message passing arrays north fold 242 !!----------------------------------------------------------------------243 !! OPA 9.0 , LODYC-IPSL (2003)244 !!---------------------------------------------------------------------231 !!---------------------------------------------------------------------- 232 !! OPA 9.0 , LODYC-IPSL (2004) 233 !!--------------------------------------------------------------------- 245 234 246 235 CONTAINS 247 236 248 FUNCTION mynode()249 !!----------------------------------------------------------------------250 !! *** routine mynode ***251 !!252 !! ** Purpose : Find processor unit253 !!254 !!----------------------------------------------------------------------237 FUNCTION mynode() 238 !!---------------------------------------------------------------------- 239 !! *** routine mynode *** 240 !! 241 !! ** Purpose : Find processor unit 242 !! 243 !!---------------------------------------------------------------------- 255 244 #if defined key_mpp_mpi 256 !! * Local variables (MPI version) 257 INTEGER :: mynode, ierr 258 !!---------------------------------------------------------------------- 259 ! Enroll in MPI 260 ! ------------- 261 CALL mpi_init_opa( ierr ) 262 CALL mpi_comm_rank( mpi_comm_world, rank, ierr ) 263 CALL mpi_comm_size( mpi_comm_world, size, ierr ) 264 mynode = rank 245 !! * Local variables (MPI version) 246 INTEGER :: mynode, ierr 247 !!---------------------------------------------------------------------- 248 ! Enroll in MPI 249 ! ------------- 250 !!! CALL mpi_init_opa( ierr ) 251 CALL mpi_init( ierr ) 252 CALL mpi_comm_rank( mpi_comm_world, rank, ierr ) 253 CALL mpi_comm_size( mpi_comm_world, size, ierr ) 254 mynode = rank 265 255 #else 266 !! * Local variables (SHMEM version) 267 INTEGER :: mynode 268 INTEGER :: & 269 imypid, imyhost, ji, info, iparent_tid 270 !!---------------------------------------------------------------------- 271 272 IF( npvm_ipas /= nprocmax ) THEN 273 ! --- first passage in mynode 274 ! ------------- 275 ! enroll in pvm 276 ! ------------- 277 CALL pvmfmytid( npvm_mytid ) 278 IF( mynode_print /= 0 ) THEN 279 WRITE(nummpp,*) 'mynode, npvm_ipas=',npvm_ipas, ' nprocmax=',nprocmax 280 WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, ' after pvmfmytid' 281 ENDIF 282 283 ! --------------------------------------------------------------- 284 ! find out IF i am parent or child spawned processes have parents 285 ! --------------------------------------------------------------- 286 CALL mpparent( iparent_tid ) 287 IF( mynode_print /= 0 ) THEN 288 WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, & 289 ' after mpparent, npvm_tids(0) = ', & 290 npvm_tids(0),' iparent_tid=', iparent_tid 291 ENDIF 292 IF(iparent_tid < 0 ) THEN 293 WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, & 294 ' after mpparent, npvm_tids(0) = ', & 295 npvm_tids(0),' iparent_tid=', iparent_tid 296 npvm_tids(0) = npvm_mytid 297 npvm_me = 0 298 IF( ndim_mpp > nprocmax ) THEN 299 WRITE(nummpp,*) 'npvm_mytid=',npvm_mytid,' too great' 300 STOP ' mynode ' 301 ELSE 302 npvm_nproc = ndim_mpp 303 ENDIF 304 305 ! ------------------------- 306 ! start up copies of myself 307 ! ------------------------- 308 IF( npvm_nproc > 1 ) THEN 309 DO ji = 1, npvm_nproc-1 310 npvm_tids(ji) = nt3d_tids(ji) 311 END DO 312 info=npvm_nproc-1 313 314 IF(mynode_print /= 0 ) THEN 315 WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, & 316 ' maitre=',executable,' info=',info & 317 ,' npvm_nproc=',npvm_nproc 318 WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, & 319 ' npvm_tids ',(npvm_tids(ji),ji=0,npvm_nproc-1) 320 ENDIF 321 322 ! --------------------------- 323 ! multicast tids array to children 324 ! --------------------------- 325 CALL pvmfinitsend( pvmdefault, info ) 326 CALL pvmfpack(jpvmint,npvm_nproc,1,1,info) 327 CALL pvmfpack(jpvmint,npvm_tids,npvm_nproc,1,info) 328 CALL pvmfmcast(npvm_nproc-1,npvm_tids(1),10,info) 329 ENDIF 330 ELSE 331 332 ! --------------------------------- 333 ! receive the tids array and set me 334 ! --------------------------------- 335 IF(mynode_print /= 0 ) THEN 336 WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, ' pvmfrecv' 337 ENDIF 338 CALL pvmfrecv( iparent_tid, 10, info ) 339 IF(mynode_print /= 0 ) THEN 340 WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, " fin pvmfrecv" 341 ENDIF 342 CALL pvmfunpack(jpvmint,npvm_nproc,1,1,info) 343 CALL pvmfunpack(jpvmint,npvm_tids,npvm_nproc,1,info) 344 IF( mynode_print /= 0 ) THEN 345 WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, & 346 ' esclave=', executable,' info=',info & 347 ,' npvm_nproc=',npvm_nproc 348 WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, & 349 'npvm_tids',(npvm_tids(ji),ji=0,npvm_nproc-1) 350 ENDIF 351 DO ji = 0, npvm_nproc-1 352 IF( npvm_mytid == npvm_tids(ji) ) npvm_me = ji 353 END DO 354 ENDIF 355 356 ! ------------------------------------------------------------ 357 ! all nproc tasks are equal now 358 ! and can address each other by tids(0) thru tids(nproc-1) 359 ! for each process me => process number [0-(nproc-1)] 360 ! ------------------------------------------------------------ 361 CALL pvmfjoingroup ("bidon", info) 362 CALL pvmfbarrier ("bidon", npvm_nproc, info) 363 DO ji=0, npvm_nproc-1 364 IF(ji == npvm_me ) THEN 365 CALL pvmfjoingroup (opaall, npvm_inum) 366 IF( npvm_inum /= npvm_me) WRITE(nummpp,*) 'mynode', & 367 ' not arrived in the good order for opaall' 368 ENDIF 369 CALL pvmfbarrier("bidon",npvm_nproc,info) 370 END DO 371 CALL pvmfbarrier(opaall,npvm_nproc,info) 372 373 ELSE 374 ! --- other passage in mynode 375 ENDIF 376 377 npvm_ipas = nprocmax 378 mynode = npvm_me 379 imypid = npvm_mytid 380 imyhost = npvm_tids(0) 381 IF( mynode_print /= 0 ) THEN 382 WRITE(nummpp,*)'mynode, npvm_mytid=',npvm_mytid & 383 ,' npvm_me=',npvm_me, ' npvm_nproc=',npvm_nproc ,' npvm_ipas=',npvm_ipas 384 ENDIF 385 #endif 386 END FUNCTION mynode 387 388 389 SUBROUTINE mpparent( kparent_tid ) 390 !!---------------------------------------------------------------------- 391 !! *** routine mpparent *** 392 !! 393 !! ** Purpose : use an pvmfparent routine for T3E (key_mpp_shmem) 394 !! or only RETURN -1 (key_mpp_mpi) 395 !!---------------------------------------------------------------------- 396 !! * Arguments 397 INTEGER, INTENT(inout) :: kparent_tid ! ??? 398 256 !! * Local variables (SHMEM version) 257 INTEGER :: mynode 258 INTEGER :: & 259 imypid, imyhost, ji, info, iparent_tid 260 !!---------------------------------------------------------------------- 261 262 IF( npvm_ipas /= nprocmax ) THEN 263 ! --- first passage in mynode 264 ! ------------- 265 ! enroll in pvm 266 ! ------------- 267 CALL pvmfmytid( npvm_mytid ) 268 IF( mynode_print /= 0 ) THEN 269 WRITE(nummpp,*) 'mynode, npvm_ipas =', npvm_ipas, ' nprocmax=', nprocmax 270 WRITE(nummpp,*) 'mynode, npvm_mytid=', npvm_mytid, ' after pvmfmytid' 271 ENDIF 272 273 ! --------------------------------------------------------------- 274 ! find out IF i am parent or child spawned processes have parents 275 ! --------------------------------------------------------------- 276 CALL mpparent( iparent_tid ) 277 IF( mynode_print /= 0 ) THEN 278 WRITE(nummpp,*) 'mynode, npvm_mytid=', npvm_mytid, & 279 & ' after mpparent, npvm_tids(0) = ', & 280 & npvm_tids(0), ' iparent_tid=', iparent_tid 281 ENDIF 282 IF( iparent_tid < 0 ) THEN 283 WRITE(nummpp,*) 'mynode, npvm_mytid=', npvm_mytid, & 284 & ' after mpparent, npvm_tids(0) = ', & 285 & npvm_tids(0), ' iparent_tid=', iparent_tid 286 npvm_tids(0) = npvm_mytid 287 npvm_me = 0 288 IF( ndim_mpp > nprocmax ) THEN 289 WRITE(nummpp,*) 'npvm_mytid=', npvm_mytid, ' too great' 290 STOP ' mynode ' 291 ELSE 292 npvm_nproc = ndim_mpp 293 ENDIF 294 295 ! ------------------------- 296 ! start up copies of myself 297 ! ------------------------- 298 IF( npvm_nproc > 1 ) THEN 299 DO ji = 1, npvm_nproc-1 300 npvm_tids(ji) = nt3d_tids(ji) 301 END DO 302 info=npvm_nproc-1 303 304 IF( mynode_print /= 0 ) THEN 305 WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, & 306 & ' maitre=',executable,' info=', info & 307 & ,' npvm_nproc=',npvm_nproc 308 WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, & 309 & ' npvm_tids ',(npvm_tids(ji),ji=0,npvm_nproc-1) 310 ENDIF 311 312 ! --------------------------- 313 ! multicast tids array to children 314 ! --------------------------- 315 CALL pvmfinitsend( pvmdefault, info ) 316 CALL pvmfpack ( jpvmint, npvm_nproc, 1 , 1, info ) 317 CALL pvmfpack ( jpvmint, npvm_tids , npvm_nproc, 1, info ) 318 CALL pvmfmcast( npvm_nproc-1, npvm_tids(1), 10, info ) 319 ENDIF 320 ELSE 321 322 ! --------------------------------- 323 ! receive the tids array and set me 324 ! --------------------------------- 325 IF( mynode_print /= 0 ) WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, ' pvmfrecv' 326 CALL pvmfrecv( iparent_tid, 10, info ) 327 IF( mynode_print /= 0 ) WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, " fin pvmfrecv" 328 CALL pvmfunpack( jpvmint, npvm_nproc, 1 , 1, info ) 329 CALL pvmfunpack( jpvmint, npvm_tids , npvm_nproc, 1, info ) 330 IF( mynode_print /= 0 ) THEN 331 WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, & 332 & ' esclave=', executable,' info=', info,' npvm_nproc=',npvm_nproc 333 WRITE(nummpp,*) 'mynode, npvm_mytid=', npvm_mytid, & 334 & 'npvm_tids', ( npvm_tids(ji), ji = 0, npvm_nproc-1 ) 335 ENDIF 336 DO ji = 0, npvm_nproc-1 337 IF( npvm_mytid == npvm_tids(ji) ) npvm_me = ji 338 END DO 339 ENDIF 340 341 ! ------------------------------------------------------------ 342 ! all nproc tasks are equal now 343 ! and can address each other by tids(0) thru tids(nproc-1) 344 ! for each process me => process number [0-(nproc-1)] 345 ! ------------------------------------------------------------ 346 CALL pvmfjoingroup ( "bidon", info ) 347 CALL pvmfbarrier ( "bidon", npvm_nproc, info ) 348 DO ji = 0, npvm_nproc-1 349 IF( ji == npvm_me ) THEN 350 CALL pvmfjoingroup ( opaall, npvm_inum ) 351 IF( npvm_inum /= npvm_me ) WRITE(nummpp,*) 'mynode not arrived in the good order for opaall' 352 ENDIF 353 CALL pvmfbarrier( "bidon", npvm_nproc, info ) 354 END DO 355 CALL pvmfbarrier( opaall, npvm_nproc, info ) 356 357 ELSE 358 ! --- other passage in mynode 359 ENDIF 360 361 npvm_ipas = nprocmax 362 mynode = npvm_me 363 imypid = npvm_mytid 364 imyhost = npvm_tids(0) 365 IF( mynode_print /= 0 ) THEN 366 WRITE(nummpp,*)'mynode: npvm_mytid=', npvm_mytid, ' npvm_me=', npvm_me, & 367 & ' npvm_nproc=', npvm_nproc , ' npvm_ipas=', npvm_ipas 368 ENDIF 369 #endif 370 END FUNCTION mynode 371 372 373 SUBROUTINE mpparent( kparent_tid ) 374 !!---------------------------------------------------------------------- 375 !! *** routine mpparent *** 376 !! 377 !! ** Purpose : use an pvmfparent routine for T3E (key_mpp_shmem) 378 !! or only return -1 (key_mpp_mpi) 379 !!---------------------------------------------------------------------- 380 !! * Arguments 381 INTEGER, INTENT(inout) :: kparent_tid ! ??? 382 399 383 #if defined key_mpp_mpi 400 !! * Local variables (MPI version)401 402 kparent_tid=-1384 ! MPI version : retour -1 385 386 kparent_tid = -1 403 387 404 388 #else 405 !! * Local variables (SHMEN onto T3E version)406 INTEGER :: &407 it3d_my_pe, LEADZ, ji, info408 409 CALL pvmfmytid( nt3d_mytid )410 CALL pvmfgetpe( nt3d_mytid, it3d_my_pe )411 IF( mpparent_print /= 0 ) THEN412 WRITE(nummpp,*) 'mpparent,nt3d_mytid= ', nt3d_mytid ,' it3d_my_pe=',it3d_my_pe413 ENDIF414 IF( it3d_my_pe == 0 ) THEN415 !-----------------------------------------------------------------!416 ! process = 0 => receive other tids !417 !-----------------------------------------------------------------!418 kparent_tid = -1419 IF(mpparent_print /= 0 ) THEN420 WRITE(nummpp,*) 'mpparent, nt3d_mytid=',nt3d_mytid ,' kparent_tid=',kparent_tid421 ENDIF422 ! --- END receive dimension ---423 IF( ndim_mpp > nprocmax ) THEN424 WRITE(nummpp,*) 'mytid=',nt3d_mytid,' too great'425 STOP ' mpparent '426 ELSE427 nt3d_nproc = ndim_mpp428 ENDIF429 IF(mpparent_print /= 0 ) THEN430 WRITE(nummpp,*) 'mpparent, nt3d_mytid=',nt3d_mytid ,' nt3d_nproc=',nt3d_nproc431 ENDIF432 !-------- receive tids from others process --------433 DO ji = 1, nt3d_nproc-1434 CALL pvmfrecv( ji , 100, info )435 CALL pvmfunpack(jpvmint,nt3d_tids(ji),1,1,info)436 IF(mpparent_print /= 0 ) THEN437 WRITE(nummpp,*) 'mpparent, nt3d_mytid=',nt3d_mytid ,' receive=',nt3d_tids(ji),' from = ',ji438 ENDIF439 END DO440 nt3d_tids(0) = nt3d_mytid441 IF(mpparent_print /= 0 ) THEN442 WRITE(nummpp,*) 'mpparent, nt3d_mytid=',nt3d_mytid ,' nt3d_tids(ji) =',(nt3d_tids(ji), &443 ji=0,nt3d_nproc-1)444 WRITE(nummpp,*) 'mpparent, nt3d_mytid=',nt3d_mytid ,' kparent_tid=',kparent_tid445 ENDIF446 447 ELSE448 !!----------------------------------------------------------------!449 ! process <> 0 => send other tids !450 !!----------------------------------------------------------------!451 kparent_tid = 0452 CALL pvmfinitsend( pvmdataraw, info )453 CALL pvmfpack( jpvmint, nt3d_mytid, 1, 1, info )454 CALL pvmfsend( kparent_tid, 100, info )455 ENDIF456 #endif 457 458 END SUBROUTINE mpparent389 !! * Local variables (SHMEN onto T3E version) 390 INTEGER :: & 391 it3d_my_pe, LEADZ, ji, info 392 393 CALL pvmfmytid( nt3d_mytid ) 394 CALL pvmfgetpe( nt3d_mytid, it3d_my_pe ) 395 IF( mpparent_print /= 0 ) THEN 396 WRITE(nummpp,*) 'mpparent: nt3d_mytid= ', nt3d_mytid ,' it3d_my_pe=',it3d_my_pe 397 ENDIF 398 IF( it3d_my_pe == 0 ) THEN 399 !-----------------------------------------------------------------! 400 ! process = 0 => receive other tids ! 401 !-----------------------------------------------------------------! 402 kparent_tid = -1 403 IF(mpparent_print /= 0 ) THEN 404 WRITE(nummpp,*) 'mpparent, nt3d_mytid=',nt3d_mytid ,' kparent_tid=',kparent_tid 405 ENDIF 406 ! --- END receive dimension --- 407 IF( ndim_mpp > nprocmax ) THEN 408 WRITE(nummpp,*) 'mytid=',nt3d_mytid,' too great' 409 STOP ' mpparent ' 410 ELSE 411 nt3d_nproc = ndim_mpp 412 ENDIF 413 IF( mpparent_print /= 0 ) THEN 414 WRITE(nummpp,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_nproc=', nt3d_nproc 415 ENDIF 416 !-------- receive tids from others process -------- 417 DO ji = 1, nt3d_nproc-1 418 CALL pvmfrecv( ji , 100, info ) 419 CALL pvmfunpack( jpvmint, nt3d_tids(ji), 1, 1, info ) 420 IF( mpparent_print /= 0 ) THEN 421 WRITE(nummpp,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' receive=', nt3d_tids(ji), ' from = ', ji 422 ENDIF 423 END DO 424 nt3d_tids(0) = nt3d_mytid 425 IF( mpparent_print /= 0 ) THEN 426 WRITE(nummpp,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_tids(ji) =', (nt3d_tids(ji), & 427 ji = 0, nt3d_nproc-1 ) 428 WRITE(nummpp,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' kparent_tid=', kparent_tid 429 ENDIF 430 431 ELSE 432 !!----------------------------------------------------------------! 433 ! process <> 0 => send other tids ! 434 !!----------------------------------------------------------------! 435 kparent_tid = 0 436 CALL pvmfinitsend( pvmdataraw, info ) 437 CALL pvmfpack( jpvmint, nt3d_mytid, 1, 1, info ) 438 CALL pvmfsend( kparent_tid, 100, info ) 439 ENDIF 440 #endif 441 442 END SUBROUTINE mpparent 459 443 460 444 #if defined key_mpp_shmem 461 445 462 SUBROUTINE mppshmem463 !!----------------------------------------------------------------------464 !! *** routine mppshmem ***465 !!466 !! ** Purpose : SHMEM ROUTINE467 !!468 !!----------------------------------------------------------------------469 nrs1sync_shmem = SHMEM_SYNC_VALUE470 nrs2sync_shmem = SHMEM_SYNC_VALUE471 nis1sync_shmem = SHMEM_SYNC_VALUE472 nis2sync_shmem = SHMEM_SYNC_VALUE473 nil1sync_shmem = SHMEM_SYNC_VALUE474 nil2sync_shmem = SHMEM_SYNC_VALUE475 ni11sync_shmem = SHMEM_SYNC_VALUE476 ni12sync_shmem = SHMEM_SYNC_VALUE477 ni21sync_shmem = SHMEM_SYNC_VALUE478 ni22sync_shmem = SHMEM_SYNC_VALUE479 CALL barrier()480 481 END SUBROUTINE mppshmem482 483 #endif 484 485 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn )486 !!----------------------------------------------------------------------487 !! *** routine mpp_lnk_3d ***488 !!489 !! ** Purpose : Message passing manadgement490 !!491 !! ** Method : Use mppsend and mpprecv function for passing mask492 !! between processors following neighboring subdomains.493 !! domain parameters494 !! nlci : first dimension of the local subdomain495 !! nlcj : second dimension of the local subdomain496 !! nbondi : mark for "east-west local boundary"497 !! nbondj : mark for "north-south local boundary"498 !! noea : number for local neighboring processors499 !! nowe : number for local neighboring processors500 !! noso : number for local neighboring processors501 !! nono : number for local neighboring processors502 !!503 !! ** Action : ptab with update value at its periphery504 !!505 !!----------------------------------------------------------------------506 !! * Arguments507 CHARACTER(len=1) , INTENT( in ) :: &446 SUBROUTINE mppshmem 447 !!---------------------------------------------------------------------- 448 !! *** routine mppshmem *** 449 !! 450 !! ** Purpose : SHMEM ROUTINE 451 !! 452 !!---------------------------------------------------------------------- 453 nrs1sync_shmem = SHMEM_SYNC_VALUE 454 nrs2sync_shmem = SHMEM_SYNC_VALUE 455 nis1sync_shmem = SHMEM_SYNC_VALUE 456 nis2sync_shmem = SHMEM_SYNC_VALUE 457 nil1sync_shmem = SHMEM_SYNC_VALUE 458 nil2sync_shmem = SHMEM_SYNC_VALUE 459 ni11sync_shmem = SHMEM_SYNC_VALUE 460 ni12sync_shmem = SHMEM_SYNC_VALUE 461 ni21sync_shmem = SHMEM_SYNC_VALUE 462 ni22sync_shmem = SHMEM_SYNC_VALUE 463 CALL barrier() 464 465 END SUBROUTINE mppshmem 466 467 #endif 468 469 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn ) 470 !!---------------------------------------------------------------------- 471 !! *** routine mpp_lnk_3d *** 472 !! 473 !! ** Purpose : Message passing manadgement 474 !! 475 !! ** Method : Use mppsend and mpprecv function for passing mask 476 !! between processors following neighboring subdomains. 477 !! domain parameters 478 !! nlci : first dimension of the local subdomain 479 !! nlcj : second dimension of the local subdomain 480 !! nbondi : mark for "east-west local boundary" 481 !! nbondj : mark for "north-south local boundary" 482 !! noea : number for local neighboring processors 483 !! nowe : number for local neighboring processors 484 !! noso : number for local neighboring processors 485 !! nono : number for local neighboring processors 486 !! 487 !! ** Action : ptab with update value at its periphery 488 !! 489 !!---------------------------------------------------------------------- 490 !! * Arguments 491 CHARACTER(len=1) , INTENT( in ) :: & 508 492 cd_type ! define the nature of ptab array grid-points 509 ! ! = T , U , V , F , W points510 ! ! = S : T-point, north fold treatment ???511 ! ! = G : F-point, north fold treatment ???512 REAL(wp), INTENT( in ) :: &493 ! ! = T , U , V , F , W points 494 ! ! = S : T-point, north fold treatment ??? 495 ! ! = G : F-point, north fold treatment ??? 496 REAL(wp), INTENT( in ) :: & 513 497 psgn ! control of the sign change 514 ! ! = -1. , the sign is changed if north fold boundary 515 ! ! = 1. , the sign is kept if north fold boundary 516 517 518 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: & 498 ! ! = -1. , the sign is changed if north fold boundary 499 ! ! = 1. , the sign is kept if north fold boundary 500 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: & 519 501 ptab ! 3D array on which the boundary condition is applied 520 502 521 !! * Local variables 522 INTEGER :: ji, jj, jk, jl ! dummy loop indices 523 INTEGER :: imigr, iihom, ijhom, iloc, ijt, iju ! temporary integers 524 !!---------------------------------------------------------------------- 525 526 ! 1. standard boundary treatment 527 ! ------------------------------ 528 529 ! East-West boundary conditions 530 531 IF( nbondi == 2.AND.(nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 532 ! ... cyclic 533 ptab( 1 ,:,:) = ptab(jpim1,:,:) 534 ptab(jpi,:,:) = ptab( 2 ,:,:) 535 ELSE 536 ! ... closed 537 538 SELECT CASE ( cd_type ) 539 540 CASE ( 'T', 'U', 'V', 'W' ) 541 iihom = nlci-jpreci 542 DO ji = 1,jpreci 543 ptab(ji,:,:) = 0.e0 544 END DO 545 546 DO ji = iihom+1,jpi 547 ptab(ji,:,:) = 0.e0 548 END DO 549 550 CASE ( 'F' ) 551 iihom = nlci-jpreci 552 DO ji = iihom+1,jpi 553 ptab(ji,:,:) = 0.e0 554 END DO 555 556 END SELECT 557 ENDIF 558 ! 559 ! North-South boundary conditions 560 561 562 SELECT CASE ( cd_type ) 563 564 CASE ( 'T', 'U', 'V', 'W' ) 565 ijhom = nlcj-jprecj 566 DO jj = 1,jprecj 567 ptab(:,jj,:) = 0.e0 568 END DO 569 570 DO jj = ijhom+1,jpj 571 ptab(:,jj,:) = 0.e0 572 END DO 573 574 CASE ( 'F' ) 575 ijhom = nlcj-jprecj 576 DO jj = ijhom+1,jpj 577 ptab(:,jj,:) = 0.e0 578 END DO 579 END SELECT 580 581 582 ! 2. East and west directions exchange 583 ! ------------------------------------ 584 585 ! 2.1 Read Dirichlet lateral conditions 586 587 SELECT CASE ( nbondi ) 588 589 CASE ( -1, 0, 1 ) ! all exept 2 590 iihom = nlci-nreci 591 DO jl = 1, jpreci 592 t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 593 t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 594 END DO 595 END SELECT 596 597 ! 2.2 Migrations 503 !! * Local variables 504 INTEGER :: ji, jk, jl ! dummy loop indices 505 INTEGER :: imigr, iihom, ijhom, iloc, ijt, iju ! temporary integers 506 !!---------------------------------------------------------------------- 507 508 ! 1. standard boundary treatment 509 ! ------------------------------ 510 ! ! East-West boundaries 511 ! ! ==================== 512 IF( nbondi == 2 .AND. & ! Cyclic east-west 513 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 514 ptab( 1 ,:,:) = ptab(jpim1,:,:) 515 ptab(jpi,:,:) = ptab( 2 ,:,:) 516 517 ELSE ! closed 518 SELECT CASE ( cd_type ) 519 CASE ( 'T', 'U', 'V', 'W' ) 520 ptab( 1 :jpreci,:,:) = 0.e0 521 ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0 522 CASE ( 'F' ) 523 ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0 524 END SELECT 525 ENDIF 526 527 ! ! North-South boundaries 528 ! ! ====================== 529 SELECT CASE ( cd_type ) 530 CASE ( 'T', 'U', 'V', 'W' ) 531 ptab(:, 1 :jprecj,:) = 0.e0 532 ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0 533 CASE ( 'F' ) 534 ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0 535 END SELECT 536 537 538 ! 2. East and west directions exchange 539 ! ------------------------------------ 540 541 ! 2.1 Read Dirichlet lateral conditions 542 543 SELECT CASE ( nbondi ) 544 CASE ( -1, 0, 1 ) ! all exept 2 545 iihom = nlci-nreci 546 DO jl = 1, jpreci 547 t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 548 t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 549 END DO 550 END SELECT 551 552 ! 2.2 Migrations 598 553 599 554 #if defined key_mpp_shmem 600 !! * SHMEM version 601 602 imigr = jpreci * jpj * jpk 603 604 SELECT CASE ( nbondi ) 605 606 CASE ( -1 ) 607 CALL shmem_put(t3we(1,1,1,2),t3we(1,1,1,1),imigr,noea) 608 609 CASE ( 0 ) 610 CALL shmem_put(t3ew(1,1,1,2),t3ew(1,1,1,1),imigr,nowe) 611 CALL shmem_put(t3we(1,1,1,2),t3we(1,1,1,1),imigr,noea) 612 613 CASE ( 1 ) 614 CALL shmem_put(t3ew(1,1,1,2),t3ew(1,1,1,1),imigr,nowe) 615 END SELECT 616 617 CALL barrier() 618 CALL shmem_udcflush() 555 !! * SHMEM version 556 557 imigr = jpreci * jpj * jpk 558 559 SELECT CASE ( nbondi ) 560 CASE ( -1 ) 561 CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea ) 562 CASE ( 0 ) 563 CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe ) 564 CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea ) 565 CASE ( 1 ) 566 CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe ) 567 END SELECT 568 569 CALL barrier() 570 CALL shmem_udcflush() 619 571 620 572 #elif defined key_mpp_mpi 621 !! * Local variables (MPI version) 622 623 imigr=jpreci*jpj*jpk 624 625 SELECT CASE ( nbondi ) 626 627 CASE ( -1 ) 628 CALL mppsend(2,t3we(1,1,1,1),imigr,noea,0) 629 CALL mpprecv(1,t3ew(1,1,1,2),imigr) 630 631 CASE ( 0 ) 632 CALL mppsend(1,t3ew(1,1,1,1),imigr,nowe,0) 633 CALL mppsend(2,t3we(1,1,1,1),imigr,noea,0) 634 CALL mpprecv(1,t3ew(1,1,1,2),imigr) 635 CALL mpprecv(2,t3we(1,1,1,2),imigr) 636 637 CASE ( 1 ) 638 CALL mppsend(1,t3ew(1,1,1,1),imigr,nowe,0) 639 CALL mpprecv(2,t3we(1,1,1,2),imigr) 640 END SELECT 641 642 #endif 643 644 ! 2.3 Write Dirichlet lateral conditions 645 646 iihom = nlci-jpreci 647 SELECT CASE ( nbondi ) 648 649 CASE ( -1 ) 650 DO jl = 1, jpreci 651 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 652 END DO 653 654 CASE ( 0 ) 655 DO jl = 1, jpreci 656 ptab(jl ,:,:) = t3we(:,jl,:,2) 657 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 658 END DO 659 660 CASE ( 1 ) 661 DO jl = 1, jpreci 662 ptab(jl ,:,:) = t3we(:,jl,:,2) 663 END DO 664 END SELECT 665 666 667 ! 3. North and south directions 668 ! ----------------------------- 669 670 ! 3.1 Read Dirichlet lateral conditions 671 672 IF( nbondj /= 2 ) THEN 673 ijhom = nlcj-nrecj 674 675 DO jl = 1, jprecj 676 t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 677 t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 678 END DO 679 ENDIF 680 681 ! 3.2 Migrations 573 !! * Local variables (MPI version) 574 575 imigr = jpreci * jpj * jpk 576 577 SELECT CASE ( nbondi ) 578 CASE ( -1 ) 579 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea ) 580 CALL mpprecv( 1, t3ew(1,1,1,2), imigr ) 581 CASE ( 0 ) 582 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe ) 583 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea ) 584 CALL mpprecv( 1, t3ew(1,1,1,2), imigr ) 585 CALL mpprecv( 2, t3we(1,1,1,2), imigr ) 586 CASE ( 1 ) 587 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe ) 588 CALL mpprecv( 2, t3we(1,1,1,2), imigr ) 589 END SELECT 590 #endif 591 592 ! 2.3 Write Dirichlet lateral conditions 593 594 iihom = nlci-jpreci 595 596 SELECT CASE ( nbondi ) 597 CASE ( -1 ) 598 DO jl = 1, jpreci 599 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 600 END DO 601 CASE ( 0 ) 602 DO jl = 1, jpreci 603 ptab(jl ,:,:) = t3we(:,jl,:,2) 604 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 605 END DO 606 CASE ( 1 ) 607 DO jl = 1, jpreci 608 ptab(jl ,:,:) = t3we(:,jl,:,2) 609 END DO 610 END SELECT 611 612 613 ! 3. North and south directions 614 ! ----------------------------- 615 616 ! 3.1 Read Dirichlet lateral conditions 617 618 IF( nbondj /= 2 ) THEN 619 ijhom = nlcj-nrecj 620 DO jl = 1, jprecj 621 t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 622 t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 623 END DO 624 ENDIF 625 626 ! 3.2 Migrations 682 627 683 628 #if defined key_mpp_shmem 684 !! * SHMEM version 685 686 imigr=jprecj*jpi*jpk 687 688 SELECT CASE ( nbondj ) 689 690 CASE ( -1 ) 691 CALL shmem_put(t3sn(1,1,1,2),t3sn(1,1,1,1),imigr,nono) 692 693 CASE ( 0 ) 694 CALL shmem_put(t3ns(1,1,1,2),t3ns(1,1,1,1),imigr,noso) 695 CALL shmem_put(t3sn(1,1,1,2),t3sn(1,1,1,1),imigr,nono) 696 697 CASE ( 1 ) 698 CALL shmem_put(t3ns(1,1,1,2),t3ns(1,1,1,1),imigr,noso) 699 700 END SELECT 701 CALL barrier() 702 CALL shmem_udcflush() 629 !! * SHMEM version 630 631 imigr = jprecj * jpi * jpk 632 633 SELECT CASE ( nbondj ) 634 CASE ( -1 ) 635 CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono ) 636 CASE ( 0 ) 637 CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso ) 638 CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono ) 639 CASE ( 1 ) 640 CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso ) 641 END SELECT 642 643 CALL barrier() 644 CALL shmem_udcflush() 703 645 704 646 #elif defined key_mpp_mpi 705 !! * Local variables (MPI version) 706 707 imigr=jprecj*jpi*jpk 708 709 SELECT CASE ( nbondj ) 710 711 CASE ( -1 ) 712 CALL mppsend(4,t3sn(1,1,1,1),imigr,nono,0) 713 CALL mpprecv(3,t3ns(1,1,1,2),imigr) 714 715 CASE ( 0 ) 716 CALL mppsend(3,t3ns(1,1,1,1),imigr,noso,0) 717 CALL mppsend(4,t3sn(1,1,1,1),imigr,nono,0) 718 CALL mpprecv(3,t3ns(1,1,1,2),imigr) 719 CALL mpprecv(4,t3sn(1,1,1,2),imigr) 720 721 CASE ( 1 ) 722 CALL mppsend(3,t3ns(1,1,1,1),imigr,noso,0) 723 CALL mpprecv(4,t3sn(1,1,1,2),imigr) 724 END SELECT 725 726 #endif 727 728 ! 3.3 Write Dirichlet lateral conditions 729 730 ijhom = nlcj-jprecj 731 732 SELECT CASE ( nbondj ) 733 734 CASE ( -1 ) 735 DO jl = 1, jprecj 736 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 737 END DO 738 739 CASE ( 0 ) 740 DO jl = 1, jprecj 741 ptab(:,jl ,:) = t3sn(:,jl,:,2) 742 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 743 END DO 744 745 CASE ( 1 ) 746 DO jl = 1, jprecj 747 ptab(:,jl,:) = t3sn(:,jl,:,2) 748 END DO 749 750 END SELECT 751 752 753 754 ! 4. north fold treatment 755 ! ----------------------- 756 757 ! 4.1 treatment without exchange (jpni odd) 758 ! T-point pivot 759 760 SELECT CASE ( jpni ) 761 762 CASE ( 1 ) ! only one proc along I, no mpp exchange 763 764 SELECT CASE ( npolj ) 765 766 CASE ( 4 ) ! T pivot 767 iloc=jpiglo-2*(nimpp-1) 768 769 SELECT CASE ( cd_type ) 770 771 CASE ( 'T' , 'S' ) 772 DO jk = 1, jpk 773 DO ji = 2, nlci 774 ijt=iloc-ji+2 775 ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-2,jk) 776 END DO 777 DO ji = nlci/2+1, nlci 778 ijt=iloc-ji+2 779 ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk) 780 END DO 781 END DO 647 !! * Local variables (MPI version) 648 649 imigr=jprecj*jpi*jpk 650 651 SELECT CASE ( nbondj ) 652 CASE ( -1 ) 653 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono ) 654 CALL mpprecv( 3, t3ns(1,1,1,2), imigr ) 655 CASE ( 0 ) 656 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso ) 657 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono ) 658 CALL mpprecv( 3, t3ns(1,1,1,2), imigr ) 659 CALL mpprecv( 4, t3sn(1,1,1,2), imigr ) 660 CASE ( 1 ) 661 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso ) 662 CALL mpprecv( 4, t3sn(1,1,1,2), imigr ) 663 END SELECT 664 665 #endif 666 667 ! 3.3 Write Dirichlet lateral conditions 668 669 ijhom = nlcj-jprecj 670 671 SELECT CASE ( nbondj ) 672 CASE ( -1 ) 673 DO jl = 1, jprecj 674 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 675 END DO 676 CASE ( 0 ) 677 DO jl = 1, jprecj 678 ptab(:,jl ,:) = t3sn(:,jl,:,2) 679 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 680 END DO 681 CASE ( 1 ) 682 DO jl = 1, jprecj 683 ptab(:,jl,:) = t3sn(:,jl,:,2) 684 END DO 685 END SELECT 686 687 688 ! 4. north fold treatment 689 ! ----------------------- 690 691 ! 4.1 treatment without exchange (jpni odd) 692 ! T-point pivot 693 694 SELECT CASE ( jpni ) 695 696 CASE ( 1 ) ! only one proc along I, no mpp exchange 697 698 SELECT CASE ( npolj ) 699 700 CASE ( 4 ) ! T pivot 701 iloc = jpiglo - 2 * ( nimpp - 1 ) 702 703 SELECT CASE ( cd_type ) 704 705 CASE ( 'T' , 'S', 'W' ) 706 DO jk = 1, jpk 707 DO ji = 2, nlci 708 ijt=iloc-ji+2 709 ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-2,jk) 710 END DO 711 DO ji = nlci/2+1, nlci 712 ijt=iloc-ji+2 713 ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk) 714 END DO 715 END DO 782 716 783 CASE ( 'U' )784 DO jk = 1, jpk785 DO ji = 1, nlci-1786 iju=iloc-ji+1787 ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk)788 END DO789 DO ji = nlci/2, nlci-1790 iju=iloc-ji+1791 ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)792 END DO793 END DO794 795 CASE ( 'V' )796 DO jk = 1, jpk797 DO ji = 2, nlci798 ijt=iloc-ji+2799 ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-2,jk)800 ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-3,jk)801 END DO802 END DO803 804 CASE ( 'F', 'G' )805 DO jk = 1, jpk806 DO ji = 1, nlci-1807 iju=iloc-ji+1808 ptab(ji,nlcj-1,jk) = ptab(iju,nlcj-2,jk)809 ptab(ji,nlcj ,jk) = ptab(iju,nlcj-3,jk)810 END DO811 END DO812 717 CASE ( 'U' ) 718 DO jk = 1, jpk 719 DO ji = 1, nlci-1 720 iju=iloc-ji+1 721 ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk) 722 END DO 723 DO ji = nlci/2, nlci-1 724 iju=iloc-ji+1 725 ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk) 726 END DO 727 END DO 728 729 CASE ( 'V' ) 730 DO jk = 1, jpk 731 DO ji = 2, nlci 732 ijt=iloc-ji+2 733 ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-2,jk) 734 ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-3,jk) 735 END DO 736 END DO 737 738 CASE ( 'F', 'G' ) 739 DO jk = 1, jpk 740 DO ji = 1, nlci-1 741 iju=iloc-ji+1 742 ptab(ji,nlcj-1,jk) = ptab(iju,nlcj-2,jk) 743 ptab(ji,nlcj ,jk) = ptab(iju,nlcj-3,jk) 744 END DO 745 END DO 746 813 747 END SELECT 814 748 815 CASE ( 6 ) ! F pivot816 iloc=jpiglo-2*(nimpp-1)817 818 SELECT CASE ( cd_type )819 820 CASE ( 'T' , 'S' )821 DO jk = 1, jpk822 DO ji = 1, nlci823 ijt=iloc-ji+1824 ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-1,jk)825 END DO826 END DO827 828 CASE ( 'U' )829 DO jk = 1, jpk830 DO ji = 1, nlci-1831 iju=iloc-ji832 ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-1,jk)833 END DO834 END DO835 836 CASE ( 'V' )837 DO jk = 1, jpk838 DO ji = 1, nlci839 ijt=iloc-ji+1840 ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-2,jk)841 END DO842 DO ji = nlci/2+1, nlci843 ijt=iloc-ji+1844 ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)845 END DO846 END DO847 848 CASE ( 'F', 'G' )849 DO jk = 1, jpk850 DO ji = 1, nlci-1851 iju=iloc-ji852 ptab(ji,nlcj,jk) = ptab(iju,nlcj-2,jk)853 ptab(ji,nlcj ,jk) = ptab(iju,nlcj-3,jk)854 END DO855 DO ji = nlci/2+1, nlci-1856 iju=iloc-ji857 ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)858 END DO859 END DO860 END SELECT ! cd_type861 862 END SELECT ! npolj863 864 CASE DEFAULT ! more than 1 proc along I865 IF ( npolj /= 0 ) CALL mpp_lbc_north (ptab, cd_type, psgn) ! only for northern procs.866 867 END SELECT ! jpni868 869 870 ! 5. East and west directions exchange871 ! ------------------------------------872 873 SELECT CASE ( npolj )874 875 CASE ( 3, 4, 5, 6 )876 877 ! 5.1 Read Dirichlet lateral conditions878 879 SELECT CASE ( nbondi )880 881 CASE ( -1, 0, 1 )882 iihom = nlci-nreci883 DO jl = 1, jpreci884 t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)885 t3we(:,jl,:,1) = ptab(iihom +jl,:,:)886 END DO887 888 END SELECT889 890 ! 5.2 Migrations749 CASE ( 6 ) ! F pivot 750 iloc=jpiglo-2*(nimpp-1) 751 752 SELECT CASE ( cd_type ) 753 754 CASE ( 'T' , 'S', 'W' ) 755 DO jk = 1, jpk 756 DO ji = 1, nlci 757 ijt=iloc-ji+1 758 ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-1,jk) 759 END DO 760 END DO 761 762 CASE ( 'U' ) 763 DO jk = 1, jpk 764 DO ji = 1, nlci-1 765 iju=iloc-ji 766 ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-1,jk) 767 END DO 768 END DO 769 770 CASE ( 'V' ) 771 DO jk = 1, jpk 772 DO ji = 1, nlci 773 ijt=iloc-ji+1 774 ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-2,jk) 775 END DO 776 DO ji = nlci/2+1, nlci 777 ijt=iloc-ji+1 778 ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk) 779 END DO 780 END DO 781 782 CASE ( 'F', 'G' ) 783 DO jk = 1, jpk 784 DO ji = 1, nlci-1 785 iju=iloc-ji 786 ptab(ji,nlcj,jk) = ptab(iju,nlcj-2,jk) 787 ptab(ji,nlcj ,jk) = ptab(iju,nlcj-3,jk) 788 END DO 789 DO ji = nlci/2+1, nlci-1 790 iju=iloc-ji 791 ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk) 792 END DO 793 END DO 794 END SELECT ! cd_type 795 796 END SELECT ! npolj 797 798 CASE DEFAULT ! more than 1 proc along I 799 IF ( npolj /= 0 ) CALL mpp_lbc_north (ptab, cd_type, psgn) ! only for northern procs. 800 801 END SELECT ! jpni 802 803 804 ! 5. East and west directions exchange 805 ! ------------------------------------ 806 807 SELECT CASE ( npolj ) 808 809 CASE ( 3, 4, 5, 6 ) 810 811 ! 5.1 Read Dirichlet lateral conditions 812 813 SELECT CASE ( nbondi ) 814 815 CASE ( -1, 0, 1 ) 816 iihom = nlci-nreci 817 DO jl = 1, jpreci 818 t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 819 t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 820 END DO 821 822 END SELECT 823 824 ! 5.2 Migrations 891 825 892 826 #if defined key_mpp_shmem 893 !! * SHMEM version 894 895 imigr=jpreci*jpj*jpk 896 897 SELECT CASE ( nbondi ) 898 899 CASE ( -1 ) 900 CALL shmem_put(t3we(1,1,1,2),t3we(1,1,1,1),imigr,noea) 901 902 CASE ( 0 ) 903 CALL shmem_put(t3ew(1,1,1,2),t3ew(1,1,1,1),imigr,nowe) 904 CALL shmem_put(t3we(1,1,1,2),t3we(1,1,1,1),imigr,noea) 905 906 CASE ( 1 ) 907 CALL shmem_put(t3ew(1,1,1,2),t3ew(1,1,1,1),imigr,nowe) 908 909 END SELECT 910 CALL barrier() 911 CALL shmem_udcflush() 827 !! SHMEM version 828 829 imigr = jpreci * jpj * jpk 830 831 SELECT CASE ( nbondi ) 832 CASE ( -1 ) 833 CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea ) 834 CASE ( 0 ) 835 CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe ) 836 CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea ) 837 CASE ( 1 ) 838 CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe ) 839 END SELECT 840 841 CALL barrier() 842 CALL shmem_udcflush() 912 843 913 844 #elif defined key_mpp_mpi 914 !! * Local variables (MPI version) 915 916 imigr=jpreci*jpj*jpk 917 918 SELECT CASE ( nbondi ) 919 920 CASE ( -1 ) 921 CALL mppsend(2,t3we(1,1,1,1),imigr,noea,0) 922 CALL mpprecv(1,t3ew(1,1,1,2),imigr) 923 924 CASE ( 0 ) 925 CALL mppsend(1,t3ew(1,1,1,1),imigr,nowe,0) 926 CALL mppsend(2,t3we(1,1,1,1),imigr,noea,0) 927 CALL mpprecv(1,t3ew(1,1,1,2),imigr) 928 CALL mpprecv(2,t3we(1,1,1,2),imigr) 929 930 CASE ( 1 ) 931 CALL mppsend(1,t3ew(1,1,1,1),imigr,nowe,0) 932 CALL mpprecv(2,t3we(1,1,1,2),imigr) 933 END SELECT 934 935 #endif 936 937 ! 5.3 Write Dirichlet lateral conditions 938 939 iihom = nlci-jpreci 940 941 SELECT CASE ( nbondi) 942 943 CASE ( -1 ) 944 DO jl = 1, jpreci 945 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 946 END DO 947 948 CASE ( 0 ) 949 DO jl = 1, jpreci 950 ptab(jl ,:,:) = t3we(:,jl,:,2) 951 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 952 END DO 953 954 CASE ( 1 ) 955 DO jl = 1, jpreci 956 ptab(jl ,:,:) = t3we(:,jl,:,2) 957 END DO 958 END SELECT 959 END SELECT ! npolj 960 961 END SUBROUTINE mpp_lnk_3d 962 963 964 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn ) 965 !!---------------------------------------------------------------------- 966 !! *** routine mpp_lnk_2d *** 967 !! 968 !! ** Purpose : Message passing manadgement for 2d array 969 !! 970 !! ** Method : Use mppsend and mpprecv function for passing mask 971 !! between processors following neighboring subdomains. 972 !! domain parameters 973 !! nlci : first dimension of the local subdomain 974 !! nlcj : second dimension of the local subdomain 975 !! nbondi : mark for "east-west local boundary" 976 !! nbondj : mark for "north-south local boundary" 977 !! noea : number for local neighboring processors 978 !! nowe : number for local neighboring processors 979 !! noso : number for local neighboring processors 980 !! nono : number for local neighboring processors 981 !! 982 !!---------------------------------------------------------------------- 983 !! * Arguments 984 CHARACTER(len=1) , INTENT( in ) :: & 845 !! MPI version 846 847 imigr=jpreci*jpj*jpk 848 849 SELECT CASE ( nbondi ) 850 CASE ( -1 ) 851 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea ) 852 CALL mpprecv( 1, t3ew(1,1,1,2), imigr ) 853 CASE ( 0 ) 854 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe ) 855 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea ) 856 CALL mpprecv( 1, t3ew(1,1,1,2), imigr ) 857 CALL mpprecv( 2, t3we(1,1,1,2), imigr ) 858 CASE ( 1 ) 859 CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe ) 860 CALL mpprecv( 2, t3we(1,1,1,2), imigr ) 861 END SELECT 862 #endif 863 864 ! 5.3 Write Dirichlet lateral conditions 865 866 iihom = nlci-jpreci 867 868 SELECT CASE ( nbondi) 869 CASE ( -1 ) 870 DO jl = 1, jpreci 871 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 872 END DO 873 CASE ( 0 ) 874 DO jl = 1, jpreci 875 ptab(jl ,:,:) = t3we(:,jl,:,2) 876 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 877 END DO 878 CASE ( 1 ) 879 DO jl = 1, jpreci 880 ptab(jl ,:,:) = t3we(:,jl,:,2) 881 END DO 882 END SELECT 883 884 END SELECT ! npolj 885 886 END SUBROUTINE mpp_lnk_3d 887 888 889 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn ) 890 !!---------------------------------------------------------------------- 891 !! *** routine mpp_lnk_2d *** 892 !! 893 !! ** Purpose : Message passing manadgement for 2d array 894 !! 895 !! ** Method : Use mppsend and mpprecv function for passing mask 896 !! between processors following neighboring subdomains. 897 !! domain parameters 898 !! nlci : first dimension of the local subdomain 899 !! nlcj : second dimension of the local subdomain 900 !! nbondi : mark for "east-west local boundary" 901 !! nbondj : mark for "north-south local boundary" 902 !! noea : number for local neighboring processors 903 !! nowe : number for local neighboring processors 904 !! noso : number for local neighboring processors 905 !! nono : number for local neighboring processors 906 !! 907 !!---------------------------------------------------------------------- 908 !! * Arguments 909 CHARACTER(len=1) , INTENT( in ) :: & 985 910 cd_type ! define the nature of pt2d array grid-points 986 ! ! = T , U , V , F , W987 ! ! = S : T-point, north fold treatment988 ! ! = G : F-point, north fold treatment989 ! ! = I : sea-ice velocity at F-point with index shift990 REAL(wp), INTENT( in ) :: &911 ! ! = T , U , V , F , W 912 ! ! = S : T-point, north fold treatment 913 ! ! = G : F-point, north fold treatment 914 ! ! = I : sea-ice velocity at F-point with index shift 915 REAL(wp), INTENT( in ) :: & 991 916 psgn ! control of the sign change 992 ! ! = -1. , the sign is changed if north fold boundary 993 ! ! = 1. , the sign is kept if north fold boundary 994 995 REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: & 917 ! ! = -1. , the sign is changed if north fold boundary 918 ! ! = 1. , the sign is kept if north fold boundary 919 REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: & 996 920 pt2d ! 2D array on which the boundary condition is applied 997 921 998 !! * Local variables999 INTEGER :: ji, jj, jl ! dummy loop indices1000 INTEGER :: &922 !! * Local variables 923 INTEGER :: ji, jj, jl ! dummy loop indices 924 INTEGER :: & 1001 925 imigr, iihom, ijhom, & ! temporary integers 1002 926 iloc, ijt, iju ! " " 1003 !!---------------------------------------------------------------------- 1004 1005 ! 1. standard boundary treatment 1006 ! ------------------------------ 1007 1008 ! ! East-West boundaries 1009 ! ! ==================== 1010 1011 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1012 ! ... cyclic 1013 pt2d( 1 ,:) = pt2d(jpim1,:) 1014 pt2d(jpi,:) = pt2d( 2 ,:) 1015 ELSE 1016 ! ... closed 1017 1018 SELECT CASE ( cd_type ) 1019 1020 CASE ( 'T', 'U', 'V', 'W' ) 1021 iihom = nlci-jpreci 1022 DO ji = 1,jpreci 1023 pt2d(ji,:) = 0.e0 1024 END DO 1025 1026 DO ji = iihom+1,jpi 1027 pt2d(ji,:) = 0.e0 1028 END DO 1029 1030 CASE ( 'F' ,'I' ) 1031 iihom = nlci-jpreci 1032 DO ji = iihom+1,jpi 1033 pt2d(ji,:) = 0.e0 1034 END DO 1035 1036 END SELECT 1037 ENDIF 1038 ! ! North-South boundaries 1039 ! ! ====================== 1040 1041 SELECT CASE ( cd_type ) 1042 1043 CASE ( 'T', 'U', 'V', 'W' ) 1044 ijhom = nlcj-jprecj 1045 DO jj = 1,jprecj 1046 pt2d(:,jj) = 0.e0 927 !!---------------------------------------------------------------------- 928 929 ! 1. standard boundary treatment 930 ! ------------------------------ 931 932 ! ! East-West boundaries 933 ! ! ==================== 934 IF( nbondi == 2 .AND. & ! Cyclic east-west 935 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 936 pt2d( 1 ,:) = pt2d(jpim1,:) 937 pt2d(jpi,:) = pt2d( 2 ,:) 938 939 ELSE ! ... closed 940 SELECT CASE ( cd_type ) 941 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 942 pt2d( 1 :jpreci,:) = 0.e0 943 pt2d(nlci-jpreci+1:jpi ,:) = 0.e0 944 CASE ( 'F' ) 945 pt2d(nlci-jpreci+1:jpi ,:) = 0.e0 946 END SELECT 947 ENDIF 948 949 ! ! North-South boundaries 950 ! ! ====================== 951 SELECT CASE ( cd_type ) 952 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 953 pt2d(:, 1 :jprecj) = 0.e0 954 pt2d(:,nlcj-jprecj+1:jpj ) = 0.e0 955 CASE ( 'F' ) 956 pt2d(:,nlcj-jprecj+1:jpj ) = 0.e0 957 END SELECT 958 959 960 ! 2. East and west directions 961 ! --------------------------- 962 963 ! 2.1 Read Dirichlet lateral conditions 964 965 SELECT CASE ( nbondi ) 966 CASE ( -1, 0, 1 ) ! all except 2 967 iihom = nlci-nreci 968 DO jl = 1, jpreci 969 t2ew(:,jl,1) = pt2d(jpreci+jl,:) 970 t2we(:,jl,1) = pt2d(iihom +jl,:) 971 END DO 972 END SELECT 973 974 ! 2.2 Migrations 975 976 #if defined key_mpp_shmem 977 !! * SHMEM version 978 979 imigr = jpreci * jpj 980 981 SELECT CASE ( nbondi ) 982 CASE ( -1 ) 983 CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea ) 984 CASE ( 0 ) 985 CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe ) 986 CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea ) 987 CASE ( 1 ) 988 CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe ) 989 END SELECT 990 991 CALL barrier() 992 CALL shmem_udcflush() 993 994 #elif defined key_mpp_mpi 995 !! * MPI version 996 997 imigr = jpreci * jpj 998 999 SELECT CASE ( nbondi ) 1000 CASE ( -1 ) 1001 CALL mppsend( 2, t2we(1,1,1), imigr, noea ) 1002 CALL mpprecv( 1, t2ew(1,1,2), imigr ) 1003 CASE ( 0 ) 1004 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe ) 1005 CALL mppsend( 2, t2we(1,1,1), imigr, noea ) 1006 CALL mpprecv( 1, t2ew(1,1,2), imigr ) 1007 CALL mpprecv( 2, t2we(1,1,2), imigr ) 1008 CASE ( 1 ) 1009 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe ) 1010 CALL mpprecv( 2, t2we(1,1,2), imigr ) 1011 END SELECT 1012 1013 #endif 1014 1015 ! 2.3 Write Dirichlet lateral conditions 1016 1017 iihom = nlci - jpreci 1018 SELECT CASE ( nbondi ) 1019 CASE ( -1 ) 1020 DO jl = 1, jpreci 1021 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1022 END DO 1023 CASE ( 0 ) 1024 DO jl = 1, jpreci 1025 pt2d(jl ,:) = t2we(:,jl,2) 1026 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1027 END DO 1028 CASE ( 1 ) 1029 DO jl = 1, jpreci 1030 pt2d(jl ,:) = t2we(:,jl,2) 1031 END DO 1032 END SELECT 1033 1034 1035 ! 3. North and south directions 1036 ! ----------------------------- 1037 1038 ! 3.1 Read Dirichlet lateral conditions 1039 1040 IF( nbondj /= 2 ) THEN 1041 ijhom = nlcj-nrecj 1042 DO jl = 1, jprecj 1043 t2sn(:,jl,1) = pt2d(:,ijhom +jl) 1044 t2ns(:,jl,1) = pt2d(:,jprecj+jl) 1045 END DO 1046 ENDIF 1047 1048 ! 3.2 Migrations 1049 1050 #if defined key_mpp_shmem 1051 !! * SHMEM version 1052 1053 imigr = jprecj * jpi 1054 1055 SELECT CASE ( nbondj ) 1056 CASE ( -1 ) 1057 CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono ) 1058 CASE ( 0 ) 1059 CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso ) 1060 CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono ) 1061 CASE ( 1 ) 1062 CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso ) 1063 END SELECT 1064 CALL barrier() 1065 CALL shmem_udcflush() 1066 1067 #elif defined key_mpp_mpi 1068 !! * MPI version 1069 1070 imigr = jprecj * jpi 1071 1072 SELECT CASE ( nbondj ) 1073 CASE ( -1 ) 1074 CALL mppsend( 4, t2sn(1,1,1), imigr, nono ) 1075 CALL mpprecv( 3, t2ns(1,1,2), imigr ) 1076 CASE ( 0 ) 1077 CALL mppsend( 3, t2ns(1,1,1), imigr, noso ) 1078 CALL mppsend( 4, t2sn(1,1,1), imigr, nono ) 1079 CALL mpprecv( 3, t2ns(1,1,2), imigr ) 1080 CALL mpprecv( 4, t2sn(1,1,2), imigr ) 1081 CASE ( 1 ) 1082 CALL mppsend( 3, t2ns(1,1,1), imigr, noso ) 1083 CALL mpprecv( 4, t2sn(1,1,2), imigr ) 1084 END SELECT 1085 1086 #endif 1087 1088 ! 3.3 Write Dirichlet lateral conditions 1089 1090 ijhom = nlcj - jprecj 1091 1092 SELECT CASE ( nbondj ) 1093 CASE ( -1 ) 1094 DO jl = 1, jprecj 1095 pt2d(:,ijhom+jl) = t2ns(:,jl,2) 1096 END DO 1097 CASE ( 0 ) 1098 DO jl = 1, jprecj 1099 pt2d(:,jl ) = t2sn(:,jl,2) 1100 pt2d(:,ijhom+jl) = t2ns(:,jl,2) 1101 END DO 1102 CASE ( 1 ) 1103 DO jl = 1, jprecj 1104 pt2d(:,jl ) = t2sn(:,jl,2) 1105 END DO 1106 END SELECT 1107 1108 1109 ! 4. north fold treatment 1110 ! ----------------------- 1111 1112 ! 4.1 treatment without exchange (jpni odd) 1113 1114 SELECT CASE ( jpni ) 1115 1116 CASE ( 1 ) ! only one proc along I, no mpp exchange 1117 1118 SELECT CASE ( npolj ) 1119 1120 CASE ( 4 ) ! T pivot 1121 iloc = jpiglo - 2 * ( nimpp - 1 ) 1122 1123 SELECT CASE ( cd_type ) 1124 1125 CASE ( 'T' , 'S', 'W' ) 1126 DO ji = 2, nlci 1127 ijt=iloc-ji+2 1128 pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-2) 1129 END DO 1130 DO ji = nlci/2+1, nlci 1131 ijt=iloc-ji+2 1132 pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1) 1133 END DO 1134 1135 CASE ( 'U' ) 1136 DO ji = 1, nlci-1 1137 iju=iloc-ji+1 1138 pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2) 1139 END DO 1140 DO ji = nlci/2, nlci-1 1141 iju=iloc-ji+1 1142 pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1) 1143 END DO 1144 1145 CASE ( 'V' ) 1146 DO ji = 2, nlci 1147 ijt=iloc-ji+2 1148 pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-2) 1149 pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-3) 1150 END DO 1151 1152 CASE ( 'F', 'G' ) 1153 DO ji = 1, nlci-1 1154 iju=iloc-ji+1 1155 pt2d(ji,nlcj-1) = pt2d(iju,nlcj-2) 1156 pt2d(ji,nlcj ) = pt2d(iju,nlcj-3) 1157 END DO 1158 1159 CASE ( 'I' ) ! ice U-V point 1160 pt2d(2,nlcj) = psgn * pt2d(3,nlcj-1) 1161 DO ji = 3, nlci 1162 iju = iloc - ji + 3 1163 pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1) 1164 END DO 1165 1166 END SELECT 1167 1168 CASE (6) ! F pivot 1169 iloc=jpiglo-2*(nimpp-1) 1170 1171 SELECT CASE (cd_type ) 1172 1173 CASE ( 'T', 'S', 'W' ) 1174 DO ji = 1, nlci 1175 ijt=iloc-ji+1 1176 pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-1) 1177 END DO 1178 1179 CASE ( 'U' ) 1180 DO ji = 1, nlci-1 1181 iju=iloc-ji 1182 pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1) 1183 END DO 1184 1185 CASE ( 'V' ) 1186 DO ji = 1, nlci 1187 ijt=iloc-ji+1 1188 pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-2) 1189 END DO 1190 DO ji = nlci/2+1, nlci 1191 ijt=iloc-ji+1 1192 pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1) 1193 END DO 1194 1195 CASE ( 'F', 'G' ) 1196 DO ji = 1, nlci-1 1197 iju=iloc-ji 1198 pt2d(ji,nlcj) = pt2d(iju,nlcj-2) 1199 pt2d(ji,nlcj ) = pt2d(iju,nlcj-3) 1200 END DO 1201 DO ji = nlci/2+1, nlci-1 1202 iju=iloc-ji 1203 pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1) 1204 END DO 1205 1206 CASE ( 'I' ) ! ice U-V point 1207 pt2d( 2 ,nlcj) = 0.e0 !!bug ??? 1208 DO ji = 1 , nlci-1 !!bug rob= 2,jpim1 1209 ijt = iloc - ji !!bug rob= ijt=jpi-ji+2 ??? 1210 pt2d(ji,nlcj)= 0.5 * ( pt2d(ji,nlcj-1) + psgn * pt2d(ijt,nlcj-1) ) 1211 END DO 1212 1213 END SELECT ! cd_type 1214 1215 END SELECT ! npolj 1216 1217 CASE DEFAULT ! more than 1 proc along I 1218 IF( npolj /= 0 ) CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! only for northern procs. 1219 1220 END SELECT ! jpni 1221 1222 1223 ! 5. East and west directions 1224 ! --------------------------- 1225 1226 SELECT CASE ( npolj ) 1227 1228 CASE ( 3, 4, 5, 6 ) 1229 1230 ! 5.1 Read Dirichlet lateral conditions 1231 1232 SELECT CASE ( nbondi ) 1233 CASE ( -1, 0, 1 ) 1234 iihom = nlci-nreci 1235 DO jl = 1, jpreci 1236 DO jj = 1, jpj 1237 t2ew(jj,jl,1) = pt2d(jpreci+jl,jj) 1238 t2we(jj,jl,1) = pt2d(iihom +jl,jj) 1239 END DO 1240 END DO 1241 END SELECT 1242 1243 ! 5.2 Migrations 1244 1245 #if defined key_mpp_shmem 1246 !! * SHMEM version 1247 1248 imigr=jpreci*jpj 1249 1250 SELECT CASE ( nbondi ) 1251 CASE ( -1 ) 1252 CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea ) 1253 CASE ( 0 ) 1254 CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe ) 1255 CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea ) 1256 CASE ( 1 ) 1257 CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe ) 1258 END SELECT 1259 1260 CALL barrier() 1261 CALL shmem_udcflush() 1262 1263 #elif defined key_mpp_mpi 1264 !! * MPI version 1265 1266 imigr=jpreci*jpj 1267 1268 SELECT CASE ( nbondi ) 1269 CASE ( -1 ) 1270 CALL mppsend( 2, t2we(1,1,1), imigr, noea ) 1271 CALL mpprecv( 1, t2ew(1,1,2), imigr ) 1272 CASE ( 0 ) 1273 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe ) 1274 CALL mppsend( 2, t2we(1,1,1), imigr, noea ) 1275 CALL mpprecv( 1, t2ew(1,1,2), imigr ) 1276 CALL mpprecv( 2, t2we(1,1,2), imigr ) 1277 CASE ( 1 ) 1278 CALL mppsend( 1, t2ew(1,1,1), imigr, nowe ) 1279 CALL mpprecv( 2, t2we(1,1,2), imigr ) 1280 END SELECT 1281 #endif 1282 1283 ! 5.3 Write Dirichlet lateral conditions 1284 1285 iihom = nlci - jpreci 1286 1287 SELECT CASE ( nbondi ) 1288 CASE ( -1 ) 1289 DO jl = 1, jpreci 1290 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1291 END DO 1292 CASE ( 0 ) 1293 DO jl = 1, jpreci 1294 pt2d(jl ,:) = t2we(:,jl,2) 1295 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1296 END DO 1297 CASE ( 1 ) 1298 DO jl = 1, jpreci 1299 pt2d(jl,:) = t2we(:,jl,2) 1300 END DO 1301 END SELECT 1302 1303 END SELECT ! npolj 1304 1305 END SUBROUTINE mpp_lnk_2d 1306 1307 1308 SUBROUTINE mpplnks( ptab ) 1309 !!---------------------------------------------------------------------- 1310 !! *** routine mpplnks *** 1311 !! 1312 !! ** Purpose : Message passing manadgement for add 2d array local boundary 1313 !! 1314 !! ** Method : Use mppsend and mpprecv function for passing mask between 1315 !! processors following neighboring subdomains. 1316 !! domain parameters 1317 !! nlci : first dimension of the local subdomain 1318 !! nlcj : second dimension of the local subdomain 1319 !! nbondi : mark for "east-west local boundary" 1320 !! nbondj : mark for "north-south local boundary" 1321 !! noea : number for local neighboring processors 1322 !! nowe : number for local neighboring processors 1323 !! noso : number for local neighboring processors 1324 !! nono : number for local neighboring processors 1325 !! 1326 !!---------------------------------------------------------------------- 1327 !! * Arguments 1328 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: & 1329 ptab ! 2D array 1330 1331 !! * Local variables 1332 INTEGER :: ji, jl ! dummy loop indices 1333 INTEGER :: & 1334 imigr, iihom, ijhom ! temporary integers 1335 !!---------------------------------------------------------------------- 1336 1337 1338 ! 1. north fold treatment 1339 ! ----------------------- 1340 1341 ! 1.1 treatment without exchange (jpni odd) 1342 1343 SELECT CASE ( npolj ) 1344 CASE ( 4 ) 1345 DO ji = 1, nlci 1346 ptab(ji,nlcj-2) = ptab(ji,nlcj-2)+t2p1(ji,1,1) 1347 END DO 1348 CASE ( 6 ) 1349 DO ji = 1, nlci 1350 ptab(ji,nlcj-1) = ptab(ji,nlcj-1)+t2p1(ji,1,1) 1351 END DO 1352 1353 ! 1.2 treatment with exchange (jpni greater than 1) 1354 ! 1355 CASE ( 3 ) 1356 #if defined key_mpp_shmem 1357 1358 !! * SHMEN version 1359 1360 imigr=jprecj*jpi 1361 1362 CALL shmem_put(t2p1(1,1,2),t2p1(1,1,1),imigr,nono) 1363 CALL barrier() 1364 CALL shmem_udcflush() 1365 1366 # elif defined key_mpp_mpi 1367 !! * MPI version 1368 1369 imigr=jprecj*jpi 1370 1371 CALL mppsend(3,t2p1(1,1,1),imigr,nono) 1372 CALL mpprecv(3,t2p1(1,1,2),imigr) 1373 1374 #endif 1375 1376 ! Write north fold conditions 1377 1378 DO ji = 1, nlci 1379 ptab(ji,nlcj-2) = ptab(ji,nlcj-2)+t2p1(ji,1,2) 1047 1380 END DO 1048 1381 1049 DO jj = ijhom+1,jpj 1050 pt2d(:,jj) = 0.e0 1051 END DO 1052 1053 CASE ( 'F' ) 1054 ijhom = nlcj-jprecj 1055 DO jj = ijhom+1,jpj 1056 pt2d(:,jj) = 0.e0 1057 END DO 1058 END SELECT 1059 1060 1061 ! 1062 ! 2. East and west directions 1063 ! --------------------------- 1064 1065 ! 2.1 Read Dirichlet lateral conditions 1066 1067 SELECT CASE ( nbondi ) 1068 1069 CASE ( -1, 0, 1 ) ! all except 2 1070 iihom = nlci-nreci 1071 DO jl = 1, jpreci 1072 t2ew(:,jl,1) = pt2d(jpreci+jl,:) 1073 t2we(:,jl,1) = pt2d(iihom +jl,:) 1074 END DO 1075 END SELECT 1076 1077 ! 2.2 Migrations 1078 1079 #if defined key_mpp_shmem 1080 !! * SHMEM version 1081 1082 imigr=jpreci*jpj 1083 1084 SELECT CASE ( nbondi ) 1085 1086 CASE ( -1 ) 1087 CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea) 1088 1089 CASE ( 0 ) 1090 CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe) 1091 CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea) 1092 1093 CASE ( 1 ) 1094 CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe) 1095 END SELECT 1096 1097 CALL barrier() 1098 CALL shmem_udcflush() 1099 1100 #elif defined key_mpp_mpi 1101 !! * Local variables (MPI version) 1102 1103 imigr=jpreci*jpj 1104 1105 SELECT CASE ( nbondi ) 1106 1107 CASE ( -1 ) 1108 CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 1109 CALL mpprecv(1,t2ew(1,1,2),imigr) 1110 1111 CASE ( 0 ) 1112 CALL mppsend(1,t2ew(1,1,1),imigr,nowe,0) 1113 CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 1114 CALL mpprecv(1,t2ew(1,1,2),imigr) 1115 CALL mpprecv(2,t2we(1,1,2),imigr) 1116 1117 CASE ( 1 ) 1118 CALL mppsend(1,t2ew(1,1,1),imigr,nowe,0) 1119 CALL mpprecv(2,t2we(1,1,2),imigr) 1120 END SELECT 1121 1122 #endif 1123 1124 ! 2.3 Write Dirichlet lateral conditions 1125 1126 iihom = nlci-jpreci 1127 SELECT CASE ( nbondi ) 1128 1129 CASE ( -1 ) 1130 DO jl = 1, jpreci 1131 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1132 END DO 1133 1134 CASE ( 0 ) 1135 DO jl = 1, jpreci 1136 pt2d(jl ,:) = t2we(:,jl,2) 1137 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1138 END DO 1139 1140 CASE ( 1 ) 1141 DO jl = 1, jpreci 1142 pt2d(jl ,:) = t2we(:,jl,2) 1143 END DO 1144 END SELECT 1145 1146 1147 ! 3. North and south directions 1148 ! ----------------------------- 1149 1150 ! 3.1 Read Dirichlet lateral conditions 1151 1152 IF( nbondj /= 2 ) THEN 1153 ijhom = nlcj-nrecj 1154 1155 DO jl = 1, jprecj 1156 t2sn(:,jl,1) = pt2d(:,ijhom +jl) 1157 t2ns(:,jl,1) = pt2d(:,jprecj+jl) 1158 END DO 1159 ENDIF 1160 1161 ! 3.2 Migrations 1162 1163 #if defined key_mpp_shmem 1164 !! * SHMEM version 1165 1166 imigr=jprecj*jpi 1167 1168 SELECT CASE ( nbondj ) 1169 1170 CASE ( -1 ) 1171 CALL shmem_put(t2sn(1,1,2),t2sn(1,1,1),imigr,nono) 1172 1173 CASE ( 0 ) 1174 CALL shmem_put(t2ns(1,1,2),t2ns(1,1,1),imigr,noso) 1175 CALL shmem_put(t2sn(1,1,2),t2sn(1,1,1),imigr,nono) 1176 1177 CASE ( 1 ) 1178 CALL shmem_put(t2ns(1,1,2),t2ns(1,1,1),imigr,noso) 1179 1180 END SELECT 1181 CALL barrier() 1182 CALL shmem_udcflush() 1183 1184 #elif defined key_mpp_mpi 1185 !! * Local variables (MPI version) 1186 1187 imigr=jprecj*jpi 1188 1189 SELECT CASE ( nbondj) 1190 1191 CASE ( -1 ) 1192 CALL mppsend(4,t2sn(1,1,1),imigr,nono,0) 1193 CALL mpprecv(3,t2ns(1,1,2),imigr) 1194 1195 CASE ( 0 ) 1196 CALL mppsend(3,t2ns(1,1,1),imigr,noso,0) 1197 CALL mppsend(4,t2sn(1,1,1),imigr,nono,0) 1198 CALL mpprecv(3,t2ns(1,1,2),imigr) 1199 CALL mpprecv(4,t2sn(1,1,2),imigr) 1200 1201 CASE ( 1 ) 1202 CALL mppsend(3,t2ns(1,1,1),imigr,noso,0) 1203 CALL mpprecv(4,t2sn(1,1,2),imigr) 1204 END SELECT 1205 1206 #endif 1207 1208 ! 3.3 Write Dirichlet lateral conditions 1209 1210 ijhom = nlcj-jprecj 1211 1212 SELECT CASE ( nbondj ) 1213 1214 CASE ( -1 ) 1215 DO jl = 1, jprecj 1216 pt2d(:,ijhom+jl) = t2ns(:,jl,2) 1217 END DO 1218 1219 CASE ( 0 ) 1220 DO jl = 1, jprecj 1221 pt2d(:,jl ) = t2sn(:,jl,2) 1222 pt2d(:,ijhom+jl) = t2ns(:,jl,2) 1223 END DO 1224 1225 CASE ( 1 ) 1226 DO jl = 1, jprecj 1227 pt2d(:,jl ) = t2sn(:,jl,2) 1228 END DO 1229 1230 END SELECT 1231 1232 ! 4. north fold treatment 1233 ! ----------------------- 1234 1235 ! 4.1 treatment without exchange (jpni odd) 1236 ! 1237 1238 SELECT CASE ( jpni ) 1239 1240 CASE ( 1 ) ! only one proc along I, no mpp exchange 1241 1242 SELECT CASE ( npolj ) 1243 1244 CASE ( 4 ) ! T pivot 1245 iloc=jpiglo-2*(nimpp-1) 1246 1247 SELECT CASE ( cd_type ) 1248 1249 CASE ( 'T' , 'S' ) 1250 DO ji = 2, nlci 1251 ijt=iloc-ji+2 1252 pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-2) 1253 END DO 1254 DO ji = nlci/2+1, nlci 1255 ijt=iloc-ji+2 1256 pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1) 1257 END DO 1258 1259 CASE ( 'U' ) 1260 DO ji = 1, nlci-1 1261 iju=iloc-ji+1 1262 pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2) 1263 END DO 1264 DO ji = nlci/2, nlci-1 1265 iju=iloc-ji+1 1266 pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1) 1267 END DO 1268 1269 CASE ( 'V' ) 1270 DO ji = 2, nlci 1271 ijt=iloc-ji+2 1272 pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-2) 1273 pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-3) 1274 END DO 1275 1276 CASE ( 'F', 'G' ) 1277 DO ji = 1, nlci-1 1278 iju=iloc-ji+1 1279 pt2d(ji,nlcj-1) = pt2d(iju,nlcj-2) 1280 pt2d(ji,nlcj ) = pt2d(iju,nlcj-3) 1281 END DO 1282 1283 CASE ( 'I' ) ! ice U-V point 1284 pt2d(2,nlcj) = psgn * pt2d(3,nlcj-1) 1285 DO ji = 3, nlci 1286 iju = iloc - ji + 3 1287 pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1) 1288 END DO 1289 1290 END SELECT 1291 1292 CASE (6) ! F pivot 1293 iloc=jpiglo-2*(nimpp-1) 1294 1295 SELECT CASE (cd_type ) 1296 1297 CASE ( 'T', 'S' ) 1298 DO ji = 1, nlci 1299 ijt=iloc-ji+1 1300 pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-1) 1301 END DO 1302 1303 CASE ( 'U' ) 1304 DO ji = 1, nlci-1 1305 iju=iloc-ji 1306 pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1) 1307 END DO 1308 1309 CASE ( 'V' ) 1310 DO ji = 1, nlci 1311 ijt=iloc-ji+1 1312 pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-2) 1313 END DO 1314 DO ji = nlci/2+1, nlci 1315 ijt=iloc-ji+1 1316 pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1) 1317 END DO 1318 1319 CASE ( 'F', 'G' ) 1320 DO ji = 1, nlci-1 1321 iju=iloc-ji 1322 pt2d(ji,nlcj) = pt2d(iju,nlcj-2) 1323 pt2d(ji,nlcj ) = pt2d(iju,nlcj-3) 1324 END DO 1325 DO ji = nlci/2+1, nlci-1 1326 iju=iloc-ji 1327 pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1) 1328 END DO 1329 1330 CASE ( 'I' ) ! ice U-V point 1331 pt2d( 2 ,nlcj) = 0.e0 !!bug ??? 1332 DO ji = 1 , nlci-1 !!bug rob= 2,jpim1 1333 ijt = iloc - ji !!bug rob= ijt=jpi-ji+2 ??? 1334 pt2d(ji,nlcj)= 0.5 * ( pt2d(ji,nlcj-1) + psgn * pt2d(ijt,nlcj-1) ) 1335 END DO 1336 1337 END SELECT ! cd_type 1338 1339 END SELECT ! npolj 1340 1341 CASE DEFAULT ! more than 1 proc along I 1342 IF ( npolj /= 0 ) CALL mpp_lbc_north (pt2d, cd_type, psgn) ! only for northern procs. 1343 1344 END SELECT ! jpni 1345 1346 1347 ! 5. East and west directions 1348 ! --------------------------- 1349 1350 SELECT CASE ( npolj ) 1351 1352 CASE ( 3, 4, 5, 6 ) 1353 1354 ! 5.1 Read Dirichlet lateral conditions 1355 1356 SELECT CASE ( nbondi ) 1357 1358 CASE ( -1, 0, 1 ) 1359 iihom = nlci-nreci 1360 1361 DO jl = 1, jpreci 1362 DO jj = 1, jpj 1363 t2ew(jj,jl,1) = pt2d(jpreci+jl,jj) 1364 t2we(jj,jl,1) = pt2d(iihom +jl,jj) 1365 END DO 1366 END DO 1367 1368 END SELECT 1369 1370 ! 5.2 Migrations 1371 1372 #if defined key_mpp_shmem 1373 !! * SHMEM version 1374 1375 imigr=jpreci*jpj 1376 1377 SELECT CASE ( nbondi ) 1378 1379 CASE ( -1 ) 1380 CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea) 1381 1382 CASE ( 0 ) 1383 CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe) 1384 CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea) 1385 1386 CASE ( 1 ) 1387 CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe) 1388 1389 END SELECT 1390 CALL barrier() 1391 CALL shmem_udcflush() 1392 1393 #elif defined key_mpp_mpi 1394 !! * Local variables (MPI version) 1395 1396 imigr=jpreci*jpj 1397 1398 SELECT CASE ( nbondi ) 1399 1400 CASE ( -1 ) 1401 CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 1402 CALL mpprecv(1,t2ew(1,1,2),imigr) 1403 1404 CASE ( 0 ) 1405 CALL mppsend(1,t2ew(1,1,1),imigr,nowe,0) 1406 CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 1407 CALL mpprecv(1,t2ew(1,1,2),imigr) 1408 CALL mpprecv(2,t2we(1,1,2),imigr) 1409 1410 CASE ( 1 ) 1411 CALL mppsend(1,t2ew(1,1,1),imigr,nowe,0) 1412 CALL mpprecv(2,t2we(1,1,2),imigr) 1413 END SELECT 1414 1415 #endif 1416 1417 ! 5.3 Write Dirichlet lateral conditions 1418 1419 iihom = nlci-jpreci 1420 1421 SELECT CASE ( nbondi ) 1422 1423 CASE ( -1 ) 1424 DO jl = 1, jpreci 1425 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1426 END DO 1427 1428 CASE ( 0 ) 1429 DO jl = 1, jpreci 1430 pt2d(jl ,:) = t2we(:,jl,2) 1431 pt2d(iihom+jl,:) = t2ew(:,jl,2) 1432 END DO 1433 1434 CASE ( 1 ) 1435 DO jl = 1, jpreci 1436 pt2d(jl,:) = t2we(:,jl,2) 1437 END DO 1438 END SELECT 1439 END SELECT ! npolj 1440 1441 END SUBROUTINE mpp_lnk_2d 1442 1443 1444 SUBROUTINE mpplnks( ptab ) 1445 !!---------------------------------------------------------------------- 1446 !! *** routine mpplnks *** 1447 !! 1448 !! ** Purpose : Message passing manadgement for add 2d array local boundary 1449 !! 1450 !! ** Method : Use mppsend and mpprecv function for passing mask between 1451 !! processors following neighboring subdomains. 1452 !! domain parameters 1453 !! nlci : first dimension of the local subdomain 1454 !! nlcj : second dimension of the local subdomain 1455 !! nbondi : mark for "east-west local boundary" 1456 !! nbondj : mark for "north-south local boundary" 1457 !! noea : number for local neighboring processors 1458 !! nowe : number for local neighboring processors 1459 !! noso : number for local neighboring processors 1460 !! nono : number for local neighboring processors 1461 !! 1462 !!---------------------------------------------------------------------- 1463 !! * Arguments 1464 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: & 1465 ptab ! 2D array 1466 1467 !! * Local variables 1468 INTEGER :: ji, jl ! dummy loop indices 1469 INTEGER :: & 1470 imigr, iihom, ijhom ! temporary integers 1471 !!---------------------------------------------------------------------- 1472 1473 1474 ! 1. north fold treatment 1475 ! ----------------------- 1476 1477 ! 1.1 treatment without exchange (jpni odd) 1478 ! 1479 SELECT CASE ( npolj ) 1480 1481 CASE ( 4 ) 1482 DO ji = 1, nlci 1483 ptab(ji,nlcj-2) = ptab(ji,nlcj-2)+t2p1(ji,1,1) 1484 END DO 1485 1486 CASE ( 6 ) 1487 DO ji = 1, nlci 1488 ptab(ji,nlcj-1) = ptab(ji,nlcj-1)+t2p1(ji,1,1) 1489 END DO 1490 1491 ! 1.2 treatment with exchange (jpni greater than 1) 1492 ! 1493 CASE ( 3 ) 1382 CASE ( 5 ) 1494 1383 1495 1384 #if defined key_mpp_shmem … … 1508 1397 imigr=jprecj*jpi 1509 1398 1510 CALL mppsend(3,t2p1(1,1,1),imigr,nono,0) 1511 CALL mpprecv(3,t2p1(1,1,2),imigr) 1512 1513 #endif 1514 1515 ! Write north fold conditions 1516 1517 DO ji = 1, nlci 1518 ptab(ji,nlcj-2) = ptab(ji,nlcj-2)+t2p1(ji,1,2) 1519 END DO 1520 1521 CASE ( 5 ) 1522 1523 #if defined key_mpp_shmem 1524 1525 !! * SHMEN version 1526 1527 imigr=jprecj*jpi 1528 1529 CALL shmem_put(t2p1(1,1,2),t2p1(1,1,1),imigr,nono) 1530 CALL barrier() 1531 CALL shmem_udcflush() 1532 1533 # elif defined key_mpp_mpi 1534 !! * Local variables (MPI version) 1535 1536 imigr=jprecj*jpi 1537 1538 CALL mppsend(3,t2p1(1,1,1),imigr,nono,0) 1399 CALL mppsend(3,t2p1(1,1,1),imigr,nono) 1539 1400 CALL mpprecv(3,t2p1(1,1,2),imigr) 1540 1401 … … 1598 1459 1599 1460 CASE ( -1 ) 1600 CALL mppsend(2,t2we(1,1,1),imigr,noea ,0)1461 CALL mppsend(2,t2we(1,1,1),imigr,noea) 1601 1462 CALL mpprecv(1,t2ew(1,1,2),imigr) 1602 1463 1603 1464 CASE ( 0 ) 1604 CALL mppsend(1,t2ew(1,1,1),imigr,nowe ,0)1605 CALL mppsend(2,t2we(1,1,1),imigr,noea ,0)1465 CALL mppsend(1,t2ew(1,1,1),imigr,nowe) 1466 CALL mppsend(2,t2we(1,1,1),imigr,noea) 1606 1467 CALL mpprecv(1,t2ew(1,1,2),imigr) 1607 1468 CALL mpprecv(2,t2we(1,1,2),imigr) 1608 1469 1609 1470 CASE ( 1 ) 1610 CALL mppsend(1,t2ew(1,1,1),imigr,nowe ,0)1471 CALL mppsend(1,t2ew(1,1,1),imigr,nowe) 1611 1472 CALL mpprecv(2,t2we(1,1,2),imigr) 1612 1473 … … 1688 1549 1689 1550 CASE ( -1 ) 1690 CALL mppsend(4,t2sn(1,1,1),imigr,nono ,0)1551 CALL mppsend(4,t2sn(1,1,1),imigr,nono) 1691 1552 CALL mpprecv(3,t2ns(1,1,2),imigr) 1692 1553 1693 1554 CASE ( 0 ) 1694 CALL mppsend(3,t2ns(1,1,1),imigr,noso ,0)1695 CALL mppsend(4,t2sn(1,1,1),imigr,nono ,0)1555 CALL mppsend(3,t2ns(1,1,1),imigr,noso) 1556 CALL mppsend(4,t2sn(1,1,1),imigr,nono) 1696 1557 CALL mpprecv(3,t2ns(1,1,2),imigr) 1697 1558 CALL mpprecv(4,t2sn(1,1,2),imigr) 1698 1559 1699 1560 CASE ( 1 ) 1700 CALL mppsend(3,t2ns(1,1,1),imigr,noso ,0)1561 CALL mppsend(3,t2ns(1,1,1),imigr,noso) 1701 1562 CALL mpprecv(4,t2sn(1,1,2),imigr) 1702 1563 END SELECT … … 1731 1592 1732 1593 1733 SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, kid ) 1734 !!---------------------------------------------------------------------- 1735 !! *** routine mppsend *** 1736 !! 1737 !! ** Purpose : Send messag passing array 1738 !! 1739 !! Input : 1740 !! argument : 1741 !! ktyp -> Tag of the message 1742 !! pmess -> array of real to send 1743 !! kbytes -> size of pmess in real 1744 !! kdest -> receive process number 1745 !! kid _> ? (note used) 1746 !! 1747 !!---------------------------------------------------------------------- 1748 !! * Arguments 1749 REAL(wp) :: pmess(*) 1750 INTEGER :: kbytes,kdest,ktyp,kid 1751 1594 SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest ) 1595 !!---------------------------------------------------------------------- 1596 !! *** routine mppsend *** 1597 !! 1598 !! ** Purpose : Send messag passing array 1599 !! 1600 !!---------------------------------------------------------------------- 1601 !! * Arguments 1602 REAL(wp), INTENT(inout) :: pmess(*) ! array of real 1603 INTEGER , INTENT( in ) :: kbytes, & ! size of the array pmess 1604 & kdest , & ! receive process number 1605 & ktyp ! Tag of the message 1606 !!---------------------------------------------------------------------- 1752 1607 #if defined key_mpp_shmem 1753 !! * SHMEM version : routine not used 1608 !! * SHMEM version : routine not used 1609 1610 #elif defined key_mpp_mpi 1611 !! * MPI version 1612 INTEGER :: iflag 1613 1614 CALL mpi_send( pmess, kbytes, mpi_real8, kdest, ktyp, & 1615 & mpi_comm_world, iflag ) 1616 #endif 1617 1618 END SUBROUTINE mppsend 1619 1620 1621 SUBROUTINE mpprecv( ktyp, pmess, kbytes ) 1622 !!---------------------------------------------------------------------- 1623 !! *** routine mpprecv *** 1624 !! 1625 !! ** Purpose : Receive messag passing array 1626 !! 1627 !!---------------------------------------------------------------------- 1628 !! * Arguments 1629 REAL(wp), INTENT(inout) :: pmess(*) ! array of real 1630 INTEGER , INTENT( in ) :: kbytes, & ! suze of the array pmess 1631 & ktyp ! Tag of the recevied message 1632 !!---------------------------------------------------------------------- 1633 #if defined key_mpp_shmem 1634 !! * SHMEM version : routine not used 1754 1635 1755 1636 # elif defined key_mpp_mpi 1756 !! * Local variables (MPI version) 1757 INTEGER :: iflag 1758 INTEGER :: itid_dest,info 1759 1760 CALL mpi_send(pmess,kbytes,mpi_real8,kdest,ktyp, & 1761 mpi_comm_world,iflag) 1762 #endif 1763 1764 END SUBROUTINE mppsend 1765 1766 1767 SUBROUTINE mpprecv( ktyp, pmess, kbytes ) 1768 !!---------------------------------------------------------------------- 1769 !! *** routine mpprecv *** 1770 !! 1771 !! ** Purpose : Receive messag passing array 1772 !! 1773 !!---------------------------------------------------------------------- 1774 !! * Arguments 1775 REAL(wp), INTENT(inout) :: pmess(*) ! array of real 1776 INTEGER , INTENT( in ) :: kbytes, & ! suze of the array pmess 1777 ktyp ! Tag of the recevied message 1778 1637 !! * MPI version 1638 INTEGER :: istatus(mpi_status_size) 1639 INTEGER :: iflag 1640 1641 CALL mpi_recv( pmess, kbytes, mpi_real8, mpi_any_source, ktyp, & 1642 & mpi_comm_world, istatus, iflag ) 1643 #endif 1644 1645 END SUBROUTINE mpprecv 1646 1647 1648 SUBROUTINE mppgather( ptab, kp, pio ) 1649 !!---------------------------------------------------------------------- 1650 !! *** routine mppgather *** 1651 !! 1652 !! ** Purpose : Transfert between a local subdomain array and a work 1653 !! array which is distributed following the vertical level. 1654 !! 1655 !! ** Method : 1656 !! 1657 !!---------------------------------------------------------------------- 1658 !! * Arguments 1659 REAL(wp), DIMENSION(jpi,jpj), INTENT( in ) :: ptab ! subdomain input array 1660 INTEGER , INTENT( in ) :: kp ! record length 1661 REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out ) :: pio ! subdomain input array 1662 !!--------------------------------------------------------------------- 1779 1663 #if defined key_mpp_shmem 1780 !! * SHMEM version : routine not used 1664 !! * SHMEM version 1665 1666 CALL barrier() 1667 CALL shmem_put( pio(1,1,npvm_me+1), ptab, jpi*jpj, kp ) 1668 CALL barrier() 1669 1670 #elif defined key_mpp_mpi 1671 !! * Local variables (MPI version) 1672 INTEGER :: itaille,ierror 1673 1674 itaille=jpi*jpj 1675 CALL mpi_gather( ptab, itaille, mpi_real8, pio, itaille, & 1676 & mpi_real8, kp , mpi_comm_world, ierror ) 1677 #endif 1678 1679 END SUBROUTINE mppgather 1680 1681 1682 SUBROUTINE mppscatter( pio, kp, ptab ) 1683 !!---------------------------------------------------------------------- 1684 !! *** routine mppscatter *** 1685 !! 1686 !! ** Purpose : Transfert between awork array which is distributed 1687 !! following the vertical level and the local subdomain array. 1688 !! 1689 !! ** Method : 1690 !! 1691 !!---------------------------------------------------------------------- 1692 REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array 1693 INTEGER :: kp ! Tag (not used with MPI 1694 REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input 1695 !!--------------------------------------------------------------------- 1696 #if defined key_mpp_shmem 1697 !! * SHMEM version 1698 1699 CALL barrier() 1700 CALL shmem_get( ptab, pio(1,1,npvm_me+1), jpi*jpj, kp ) 1701 CALL barrier() 1781 1702 1782 1703 # elif defined key_mpp_mpi 1783 !! * Local variables (MPI version) 1784 INTEGER :: istatus(mpi_status_size) 1785 INTEGER :: iflag 1786 1787 CALL mpi_recv( pmess, kbytes, mpi_real8, mpi_any_source, ktyp, & 1788 mpi_comm_world, istatus, iflag ) 1789 1790 #endif 1791 1792 END SUBROUTINE mpprecv 1793 1794 1795 SUBROUTINE mppgather( ptab, kk, kp, pio ) 1796 !!---------------------------------------------------------------------- 1797 !! *** routine mppgather *** 1798 !! 1799 !! ** Purpose : Transfert between a local subdomain array and a work 1800 !! array which is distributed following the vertical level. 1801 !! 1802 !! ** Method : 1803 !! 1804 !!---------------------------------------------------------------------- 1805 !! * Arguments 1806 REAL(wp), DIMENSION(jpi,jpj), INTENT( in ) :: & 1807 ptab ! subdomain input array 1808 INTEGER, INTENT( in ) :: kk ! vertical level 1809 INTEGER, INTENT( in ) :: kp ! record length 1810 REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out ) :: & 1811 pio ! subdomain input array 1812 !!--------------------------------------------------------------------- 1813 1704 !! * Local variables (MPI version) 1705 INTEGER :: itaille, ierror 1706 1707 itaille=jpi*jpj 1708 1709 CALL mpi_scatter( pio, itaille, mpi_real8, ptab, itaille, & 1710 & mpi_real8, kp, mpi_comm_world, ierror ) 1711 #endif 1712 1713 END SUBROUTINE mppscatter 1714 1715 1716 SUBROUTINE mppisl_a_int( ktab, kdim ) 1717 !!---------------------------------------------------------------------- 1718 !! *** routine mppisl_a_int *** 1719 !! 1720 !! ** Purpose : Massively parallel processors 1721 !! Find the non zero value 1722 !! 1723 !!---------------------------------------------------------------------- 1724 !! * Arguments 1725 INTEGER, INTENT( in ) :: kdim ! ??? 1726 INTEGER, INTENT(inout), DIMENSION(kdim) :: ktab ! ??? 1727 1814 1728 #if defined key_mpp_shmem 1815 !! * SHMEM version 1816 1817 CALL barrier() 1818 CALL shmem_put(pio(1,1,npvm_me+1),ptab,jpi*jpj,kp) 1819 CALL barrier() 1820 1821 #elif defined key_mpp_mpi 1822 !! * Local variables (MPI version) 1823 INTEGER :: itaille,ierror 1824 1825 itaille=jpi*jpj 1826 CALL mpi_gather(ptab,itaille,mpi_real8,pio,itaille & 1827 ,mpi_real8,kp,mpi_comm_world,ierror) 1828 #endif 1829 1830 END SUBROUTINE mppgather 1831 1832 1833 SUBROUTINE mppscatter( pio, kk, kp, ptab ) 1834 !!---------------------------------------------------------------------- 1835 !! *** routine mppscatter *** 1836 !! 1837 !! ** Purpose : Transfert between awork array which is distributed 1838 !! following the vertical level and the local subdomain array. 1839 !! 1840 !! ** Method : 1841 !! 1842 !! Input : 1843 !! argument 1844 !! pio -> output array 1845 !! kk -> process number 1846 !! kp -> Tag (not used with MPI 1847 !! 1848 !! Output : 1849 !! argument 1850 !! ptab : subdomain array input 1851 !! 1852 !!---------------------------------------------------------------------- 1853 INTEGER :: kk,kp 1854 REAL(wp),DIMENSION(jpi,jpj) :: ptab 1855 REAL(wp),DIMENSION(jpi,jpj,jpnij) :: pio 1856 !!--------------------------------------------------------------------- 1729 !! * Local variables (SHMEM version) 1730 INTEGER :: ji 1731 INTEGER, SAVE :: ibool=0 1732 1733 IF( kdim > jpmppsum ) THEN 1734 WRITE(numout,*) 'mppisl_a_int routine : kdim is too big' 1735 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 1736 STOP 'mppisl_a_int' 1737 ENDIF 1738 1739 DO ji = 1, kdim 1740 niitab_shmem(ji) = ktab(ji) 1741 END DO 1742 CALL barrier() 1743 IF(ibool == 0 ) THEN 1744 CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0 & 1745 ,0,N$PES,ni11wrk_shmem,ni11sync_shmem) 1746 CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0 & 1747 ,0,N$PES,ni12wrk_shmem,ni12sync_shmem) 1748 ELSE 1749 CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0 & 1750 ,0,N$PES,ni21wrk_shmem,ni21sync_shmem) 1751 CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0 & 1752 ,0,N$PES,ni22wrk_shmem,ni22sync_shmem) 1753 ENDIF 1754 CALL barrier() 1755 ibool=ibool+1 1756 ibool=MOD( ibool,2) 1757 DO ji = 1, kdim 1758 IF( ni11tab_shmem(ji) /= 0. ) THEN 1759 ktab(ji) = ni11tab_shmem(ji) 1760 ELSE 1761 ktab(ji) = ni12tab_shmem(ji) 1762 ENDIF 1763 END DO 1764 1765 # elif defined key_mpp_mpi 1766 !! * Local variables (MPI version) 1767 LOGICAL :: lcommute 1768 INTEGER, DIMENSION(kdim) :: iwork 1769 INTEGER :: mpi_isl,ierror 1770 1771 lcommute = .TRUE. 1772 CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror ) 1773 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer & 1774 , mpi_isl, mpi_comm_world, ierror ) 1775 ktab(:) = iwork(:) 1776 #endif 1777 1778 END SUBROUTINE mppisl_a_int 1779 1780 1781 SUBROUTINE mppisl_int( ktab ) 1782 !!---------------------------------------------------------------------- 1783 !! *** routine mppisl_int *** 1784 !! 1785 !! ** Purpose : Massively parallel processors 1786 !! Find the non zero value 1787 !! 1788 !!---------------------------------------------------------------------- 1789 !! * Arguments 1790 INTEGER , INTENT( inout ) :: ktab ! 1857 1791 1858 1792 #if defined key_mpp_shmem 1859 !! * SHMEM version 1860 1861 CALL barrier() 1862 CALL shmem_get(ptab,pio(1,1,npvm_me+1),jpi*jpj,kp) 1863 CALL barrier() 1864 1793 !! * Local variables (SHMEM version) 1794 INTEGER, SAVE :: ibool=0 1795 1796 niitab_shmem(1) = ktab 1797 CALL barrier() 1798 IF(ibool == 0 ) THEN 1799 CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0 & 1800 ,0,N$PES,ni11wrk_shmem,ni11sync_shmem) 1801 CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0 & 1802 ,0,N$PES,ni12wrk_shmem,ni12sync_shmem) 1803 ELSE 1804 CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0 & 1805 ,0,N$PES,ni21wrk_shmem,ni21sync_shmem) 1806 CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0 & 1807 ,0,N$PES,ni22wrk_shmem,ni22sync_shmem) 1808 ENDIF 1809 CALL barrier() 1810 ibool=ibool+1 1811 ibool=MOD( ibool,2) 1812 IF( ni11tab_shmem(1) /= 0. ) THEN 1813 ktab = ni11tab_shmem(1) 1814 ELSE 1815 ktab = ni12tab_shmem(1) 1816 ENDIF 1817 1865 1818 # elif defined key_mpp_mpi 1866 !! * Local variables (MPI version) 1867 INTEGER :: itaille, ierror 1868 1869 itaille=jpi*jpj 1870 1871 CALL mpi_scatter(pio,itaille,mpi_real8,ptab,itaille, & 1872 mpi_real8,kp,mpi_comm_world,ierror) 1873 1874 #endif 1875 1876 END SUBROUTINE mppscatter 1877 1878 1879 SUBROUTINE mppisl_a_int( ktab, kdim ) 1880 !!---------------------------------------------------------------------- 1881 !! *** routine mppisl_a_int *** 1882 !! 1883 !! ** Purpose : Massively parallel processors 1884 !! Find the non zero value 1885 !! 1886 !!---------------------------------------------------------------------- 1887 !! * Arguments 1888 INTEGER, INTENT( in ) :: kdim ! ??? 1889 INTEGER, INTENT(inout), DIMENSION(kdim) :: ktab ! ??? 1890 1819 1820 !! * Local variables (MPI version) 1821 LOGICAL :: lcommute 1822 INTEGER :: mpi_isl,ierror 1823 INTEGER :: iwork 1824 1825 lcommute = .TRUE. 1826 CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror) 1827 CALL mpi_allreduce(ktab, iwork, 1,mpi_integer & 1828 ,mpi_isl,mpi_comm_world,ierror) 1829 ktab = iwork 1830 #endif 1831 1832 END SUBROUTINE mppisl_int 1833 1834 1835 SUBROUTINE mppmin_a_int( ktab, kdim ) 1836 !!---------------------------------------------------------------------- 1837 !! *** routine mppmin_a_int *** 1838 !! 1839 !! ** Purpose : Find minimum value in an integer layout array 1840 !! 1841 !!---------------------------------------------------------------------- 1842 !! * Arguments 1843 INTEGER , INTENT( in ) :: kdim ! size of array 1844 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1845 1891 1846 #if defined key_mpp_shmem 1892 !! * Local variables (SHMEM version) 1893 INTEGER :: ji 1894 INTEGER, SAVE :: ibool=0 1895 1896 IF( kdim > jpmppsum ) THEN 1897 WRITE(numout,*) 'mppisl_a_int routine : kdim is too big' 1898 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 1899 STOP 'mppisl_a_int' 1900 ENDIF 1901 1902 DO ji = 1, kdim 1903 niitab_shmem(ji) = ktab(ji) 1904 END DO 1905 CALL barrier() 1906 IF(ibool == 0 ) THEN 1907 CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0 & 1908 ,0,N$PES,ni11wrk_shmem,ni11sync_shmem) 1909 CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0 & 1910 ,0,N$PES,ni12wrk_shmem,ni12sync_shmem) 1911 ELSE 1912 CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0 & 1913 ,0,N$PES,ni21wrk_shmem,ni21sync_shmem) 1914 CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0 & 1915 ,0,N$PES,ni22wrk_shmem,ni22sync_shmem) 1916 ENDIF 1917 CALL barrier() 1918 ibool=ibool+1 1919 ibool=MOD( ibool,2) 1920 DO ji = 1, kdim 1921 IF( ni11tab_shmem(ji) /= 0. ) THEN 1922 ktab(ji) = ni11tab_shmem(ji) 1923 ELSE 1924 ktab(ji) = ni12tab_shmem(ji) 1925 ENDIF 1926 END DO 1927 1847 !! * Local declarations (SHMEM version) 1848 INTEGER :: ji 1849 INTEGER, SAVE :: ibool=0 1850 1851 IF( kdim > jpmppsum ) THEN 1852 WRITE(numout,*) 'mppmin_a_int routine : kdim is too big' 1853 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 1854 STOP 'min_a_int' 1855 ENDIF 1856 1857 DO ji = 1, kdim 1858 niltab_shmem(ji) = ktab(ji) 1859 END DO 1860 CALL barrier() 1861 IF(ibool == 0 ) THEN 1862 CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0 & 1863 ,N$PES,nil1wrk_shmem,nil1sync_shmem ) 1864 ELSE 1865 CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0 & 1866 ,N$PES,nil2wrk_shmem,nil2sync_shmem ) 1867 ENDIF 1868 CALL barrier() 1869 ibool=ibool+1 1870 ibool=MOD( ibool,2) 1871 DO ji = 1, kdim 1872 ktab(ji) = niltab_shmem(ji) 1873 END DO 1874 1928 1875 # elif defined key_mpp_mpi 1929 1930 !! * Local variables (MPI version)1931 LOGICAL :: lcommute1932 INTEGER, DIMENSION(kdim) :: iwork1933 INTEGER :: mpi_isl,ierror1934 1935 lcommute=.TRUE.1936 CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror)1937 CALL mpi_allreduce(ktab,iwork,kdim,mpi_integer &1938 ,mpi_isl,mpi_comm_world,ierror) 1939 ktab(:) = iwork(:) 1940 1941 #endif 1942 1943 END SUBROUTINE mppisl_a_int1944 1945 1946 SUBROUTINE mppisl_int( ktab )1947 !!----------------------------------------------------------------------1948 !! *** routine mppisl_int ***1949 !!1950 !! ** Purpose : Massively parallel processors1951 !! Find the non zero value1952 !!1953 !!----------------------------------------------------------------------1954 !! * Arguments1955 INTEGER , INTENT( inout ) :: ktab !1876 1877 !! * Local variables (MPI version) 1878 INTEGER :: ierror 1879 INTEGER, DIMENSION(kdim) :: iwork 1880 1881 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, & 1882 & mpi_min, mpi_comm_world, ierror ) 1883 1884 ktab(:) = iwork(:) 1885 #endif 1886 1887 END SUBROUTINE mppmin_a_int 1888 1889 1890 SUBROUTINE mppmin_int( ktab ) 1891 !!---------------------------------------------------------------------- 1892 !! *** routine mppmin_int *** 1893 !! 1894 !! ** Purpose : 1895 !! Massively parallel processors 1896 !! Find minimum value in an integer layout array 1897 !! 1898 !!---------------------------------------------------------------------- 1899 !! * Arguments 1900 INTEGER, INTENT(inout) :: ktab ! ??? 1901 1902 !! * Local declarations 1956 1903 1957 1904 #if defined key_mpp_shmem 1958 !! * Local variables (SHMEM version) 1959 INTEGER, SAVE :: ibool=0 1960 1961 niitab_shmem(1) = ktab 1962 CALL barrier() 1963 IF(ibool == 0 ) THEN 1964 CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0 & 1965 ,0,N$PES,ni11wrk_shmem,ni11sync_shmem) 1966 CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0 & 1967 ,0,N$PES,ni12wrk_shmem,ni12sync_shmem) 1968 ELSE 1969 CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0 & 1970 ,0,N$PES,ni21wrk_shmem,ni21sync_shmem) 1971 CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0 & 1972 ,0,N$PES,ni22wrk_shmem,ni22sync_shmem) 1973 ENDIF 1974 CALL barrier() 1975 ibool=ibool+1 1976 ibool=MOD( ibool,2) 1977 IF( ni11tab_shmem(1) /= 0. ) THEN 1978 ktab = ni11tab_shmem(1) 1979 ELSE 1980 ktab = ni12tab_shmem(1) 1981 ENDIF 1982 1905 1906 !! * Local variables (SHMEM version) 1907 INTEGER :: ji 1908 INTEGER, SAVE :: ibool=0 1909 1910 niltab_shmem(1) = ktab 1911 CALL barrier() 1912 IF(ibool == 0 ) THEN 1913 CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0 & 1914 ,N$PES,nil1wrk_shmem,nil1sync_shmem ) 1915 ELSE 1916 CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0 & 1917 ,N$PES,nil2wrk_shmem,nil2sync_shmem ) 1918 ENDIF 1919 CALL barrier() 1920 ibool=ibool+1 1921 ibool=MOD( ibool,2) 1922 ktab = niltab_shmem(1) 1923 1983 1924 # elif defined key_mpp_mpi 1984 1925 1985 !! * Local variables (MPI version) 1986 LOGICAL :: lcommute 1987 INTEGER :: mpi_isl,ierror 1988 INTEGER :: iwork 1989 1990 lcommute = .TRUE. 1991 CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror) 1992 CALL mpi_allreduce(ktab, iwork, 1,mpi_integer & 1993 ,mpi_isl,mpi_comm_world,ierror) 1994 ktab = iwork 1995 1996 #endif 1997 1998 END SUBROUTINE mppisl_int 1999 2000 2001 SUBROUTINE mppmin_a_int( ktab, kdim ) 2002 !!---------------------------------------------------------------------- 2003 !! *** routine mppmin_a_int *** 2004 !! 2005 !! ** Purpose : Find minimum value in an integer layout array 2006 !! 2007 !!---------------------------------------------------------------------- 2008 !! * Arguments 2009 INTEGER , INTENT( in ) :: kdim ! size of array 2010 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 2011 1926 !! * Local variables (MPI version) 1927 INTEGER :: ierror, iwork 1928 1929 CALL mpi_allreduce(ktab,iwork, 1,mpi_integer & 1930 & ,mpi_min,mpi_comm_world,ierror) 1931 1932 ktab = iwork 1933 #endif 1934 1935 END SUBROUTINE mppmin_int 1936 1937 1938 SUBROUTINE mppsum_a_int( ktab, kdim ) 1939 !!---------------------------------------------------------------------- 1940 !! *** routine mppsum_a_int *** 1941 !! 1942 !! ** Purpose : Massively parallel processors 1943 !! Global integer sum 1944 !! 1945 !!---------------------------------------------------------------------- 1946 !! * Arguments 1947 INTEGER, INTENT( in ) :: kdim ! ??? 1948 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ??? 1949 2012 1950 #if defined key_mpp_shmem 2013 !! * Local declarations (SHMEM version) 2014 INTEGER :: ji 2015 INTEGER, SAVE :: ibool=0 2016 2017 IF( kdim > jpmppsum ) THEN 2018 WRITE(numout,*) 'mppmin_a_int routine : kdim is too big' 2019 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2020 STOP 'min_a_int' 2021 ENDIF 2022 2023 DO ji = 1, kdim 2024 niltab_shmem(ji) = ktab(ji) 2025 END DO 2026 CALL barrier() 2027 IF(ibool == 0 ) THEN 2028 CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0 & 2029 ,N$PES,nil1wrk_shmem,nil1sync_shmem ) 2030 ELSE 2031 CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0 & 2032 ,N$PES,nil2wrk_shmem,nil2sync_shmem ) 2033 ENDIF 2034 CALL barrier() 2035 ibool=ibool+1 2036 ibool=MOD( ibool,2) 2037 DO ji = 1, kdim 2038 ktab(ji) = niltab_shmem(ji) 2039 END DO 2040 1951 1952 !! * Local variables (SHMEM version) 1953 INTEGER :: ji 1954 INTEGER, SAVE :: ibool=0 1955 1956 IF( kdim > jpmppsum ) THEN 1957 WRITE(numout,*) 'mppsum_a_int routine : kdim is too big' 1958 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 1959 STOP 'mppsum_a_int' 1960 ENDIF 1961 1962 DO ji = 1, kdim 1963 nistab_shmem(ji) = ktab(ji) 1964 END DO 1965 CALL barrier() 1966 IF(ibool == 0 ) THEN 1967 CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0, & 1968 N$PES,nis1wrk_shmem,nis1sync_shmem) 1969 ELSE 1970 CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0, & 1971 N$PES,nis2wrk_shmem,nis2sync_shmem) 1972 ENDIF 1973 CALL barrier() 1974 ibool = ibool + 1 1975 ibool = MOD( ibool, 2 ) 1976 DO ji = 1, kdim 1977 ktab(ji) = nistab_shmem(ji) 1978 END DO 1979 2041 1980 # elif defined key_mpp_mpi 2042 1981 2043 !! * Local variables (MPI version) 2044 INTEGER :: ierror 2045 INTEGER, DIMENSION(kdim) :: iwork 2046 2047 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, & 2048 & mpi_min, mpi_comm_world, ierror ) 2049 2050 ktab(:) = iwork(:) 2051 2052 #endif 2053 2054 END SUBROUTINE mppmin_a_int 2055 2056 2057 SUBROUTINE mppmin_int( ktab ) 2058 !!---------------------------------------------------------------------- 2059 !! *** routine mppmin_int *** 2060 !! 2061 !! ** Purpose : 2062 !! Massively parallel processors 2063 !! Find minimum value in an integer layout array 2064 !! 2065 !!---------------------------------------------------------------------- 2066 !! * Arguments 2067 INTEGER, INTENT(inout) :: ktab ! ??? 2068 2069 !! * Local declarations 2070 2071 #if defined key_mpp_shmem 2072 2073 !! * Local variables (SHMEM version) 2074 INTEGER :: ji 2075 INTEGER, SAVE :: ibool=0 2076 2077 niltab_shmem(1) = ktab 2078 CALL barrier() 2079 IF(ibool == 0 ) THEN 2080 CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0 & 2081 ,N$PES,nil1wrk_shmem,nil1sync_shmem ) 2082 ELSE 2083 CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0 & 2084 ,N$PES,nil2wrk_shmem,nil2sync_shmem ) 2085 ENDIF 2086 CALL barrier() 2087 ibool=ibool+1 2088 ibool=MOD( ibool,2) 2089 ktab = niltab_shmem(1) 2090 2091 # elif defined key_mpp_mpi 2092 2093 !! * Local variables (MPI version) 2094 INTEGER :: ierror, iwork 2095 2096 CALL mpi_allreduce(ktab,iwork, 1,mpi_integer & 2097 & ,mpi_min,mpi_comm_world,ierror) 2098 2099 ktab = iwork 2100 2101 #endif 2102 2103 END SUBROUTINE mppmin_int 2104 2105 2106 SUBROUTINE mppsum_a_int( ktab, kdim ) 2107 !!---------------------------------------------------------------------- 2108 !! *** routine mppsum_a_int *** 2109 !! 2110 !! ** Purpose : Massively parallel processors 2111 !! Global integer sum 2112 !! 2113 !!---------------------------------------------------------------------- 2114 !! * Arguments 2115 INTEGER, INTENT( in ) :: kdim ! ??? 2116 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ??? 2117 2118 #if defined key_mpp_shmem 2119 2120 !! * Local variables (SHMEM version) 2121 INTEGER :: ji 2122 INTEGER, SAVE :: ibool=0 2123 2124 IF( kdim > jpmppsum ) THEN 2125 WRITE(numout,*) 'mppsum_a_int routine : kdim is too big' 2126 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2127 STOP 'mppsum_a_int' 2128 ENDIF 2129 2130 DO ji = 1, kdim 2131 nistab_shmem(ji) = ktab(ji) 2132 END DO 2133 CALL barrier() 2134 IF(ibool == 0 ) THEN 2135 CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0, & 2136 N$PES,nis1wrk_shmem,nis1sync_shmem) 2137 ELSE 2138 CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0, & 2139 N$PES,nis2wrk_shmem,nis2sync_shmem) 2140 ENDIF 2141 CALL barrier() 2142 ibool = ibool + 1 2143 ibool = MOD( ibool, 2 ) 2144 DO ji = 1, kdim 2145 ktab(ji) = nistab_shmem(ji) 2146 END DO 2147 2148 # elif defined key_mpp_mpi 2149 2150 !! * Local variables (MPI version) 2151 INTEGER :: ierror 2152 INTEGER, DIMENSION (kdim) :: iwork 2153 2154 CALL mpi_allreduce(ktab, iwork,kdim,mpi_integer & 2155 ,mpi_sum,mpi_comm_world,ierror) 2156 2157 ktab(:) = iwork(:) 2158 2159 #endif 2160 2161 END SUBROUTINE mppsum_a_int 1982 !! * Local variables (MPI version) 1983 INTEGER :: ierror 1984 INTEGER, DIMENSION (kdim) :: iwork 1985 1986 CALL mpi_allreduce(ktab, iwork,kdim,mpi_integer & 1987 ,mpi_sum,mpi_comm_world,ierror) 1988 1989 ktab(:) = iwork(:) 1990 #endif 1991 1992 END SUBROUTINE mppsum_a_int 2162 1993 2163 1994 … … 2308 2139 ,0,N$PES,wi22wrk_shmem,ni22sync_shmem) 2309 2140 ENDIF 2310 CALL 2311 ibool =ibool+12312 ibool =MOD( ibool,2)2313 IF( wi1tab_shmem(1) /= 0. ) THEN2141 CALL barrier() 2142 ibool = ibool + 1 2143 ibool = MOD( ibool, 2 ) 2144 IF( wi1tab_shmem(1) /= 0. ) THEN 2314 2145 ptab = wi1tab_shmem(1) 2315 2146 ELSE … … 2324 2155 REAL(wp) :: zwork 2325 2156 2326 CALL mpi_op_create( lc_isl,lcommute,mpi_isl,ierror)2327 CALL mpi_allreduce( ptab, zwork, 1,mpi_real8&2328 & ,mpi_isl,mpi_comm_world,ierror)2157 CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror ) 2158 CALL mpi_allreduce( ptab, zwork, 1, mpi_real8, & 2159 & mpi_isl , mpi_comm_world, ierror ) 2329 2160 ptab = zwork 2330 2161 … … 2438 2269 REAL(wp) :: zwork 2439 2270 2440 CALL mpi_allreduce( ptab, zwork, 1,mpi_real8&2441 ,mpi_max,mpi_comm_world,ierror)2271 CALL mpi_allreduce( ptab, zwork , 1 , mpi_real8, & 2272 & mpi_max, mpi_comm_world, ierror ) 2442 2273 ptab = zwork 2443 2274 … … 2687 2518 2688 2519 !! * Local declarations 2689 INTEGER :: info2520 INTEGER :: info 2690 2521 !!---------------------------------------------------------------------- 2691 2522 … … 2700 2531 CLOSE( numwrs ) ! ocean restart file 2701 2532 2702 !!!bug IF(lwp .AND. l _isl ) CLOSE( numisp )2533 !!!bug IF(lwp .AND. lk_isl ) CLOSE( numisp ) 2703 2534 2704 2535 IF( lk_dtatem ) CLOSE( numtdt ) … … 2722 2553 CALL mppsync 2723 2554 #if defined key_mpp_mpi 2724 CALL mpi_finalize( info)2555 CALL mpi_finalize( info ) 2725 2556 #endif 2726 2557 … … 2847 2678 2848 2679 IF( nbondi == -1 ) THEN 2849 CALL mppsend(2,t2we(1,1,1),imigr,noea ,0)2680 CALL mppsend(2,t2we(1,1,1),imigr,noea) 2850 2681 CALL mpprecv(1,t2ew(1,1,2),imigr) 2851 2682 ELSEIF( nbondi == 0 ) THEN 2852 CALL mppsend(1,t2ew(1,1,1),imigr,nowe ,0)2853 CALL mppsend(2,t2we(1,1,1),imigr,noea ,0)2683 CALL mppsend(1,t2ew(1,1,1),imigr,nowe) 2684 CALL mppsend(2,t2we(1,1,1),imigr,noea) 2854 2685 CALL mpprecv(1,t2ew(1,1,2),imigr) 2855 2686 CALL mpprecv(2,t2we(1,1,2),imigr) 2856 2687 ELSEIF( nbondi == 1 ) THEN 2857 CALL mppsend(1,t2ew(1,1,1),imigr,nowe ,0)2688 CALL mppsend(1,t2ew(1,1,1),imigr,nowe) 2858 2689 CALL mpprecv(2,t2we(1,1,2),imigr) 2859 2690 ENDIF … … 2914 2745 2915 2746 IF( nbondj == -1 ) THEN 2916 CALL mppsend(4,t2sn(1,1,1),imigr,nono ,0)2747 CALL mppsend(4,t2sn(1,1,1),imigr,nono) 2917 2748 CALL mpprecv(3,t2ns(1,1,2),imigr) 2918 2749 ELSEIF( nbondj == 0 ) THEN 2919 CALL mppsend(3,t2ns(1,1,1),imigr,noso ,0)2920 CALL mppsend(4,t2sn(1,1,1),imigr,nono ,0)2750 CALL mppsend(3,t2ns(1,1,1),imigr,noso) 2751 CALL mppsend(4,t2sn(1,1,1),imigr,nono) 2921 2752 CALL mpprecv(3,t2ns(1,1,2),imigr) 2922 2753 CALL mpprecv(4,t2sn(1,1,2),imigr) 2923 2754 ELSEIF( nbondj == 1 ) THEN 2924 CALL mppsend(3,t2ns(1,1,1),imigr,noso ,0)2755 CALL mppsend(3,t2ns(1,1,1),imigr,noso) 2925 2756 CALL mpprecv(4,t2sn(1,1,2),imigr) 2926 2757 ENDIF … … 2967 2798 !!---------------------------------------------------------------------- 2968 2799 !! *** routine mpp_ini_north *** 2969 2800 !! 2970 2801 !! ** Purpose : Initialize special communicator for north folding 2971 2802 !! condition together with global variables needed in the mpp folding … … 3044 2875 3045 2876 3046 SUBROUTINE mpp_lbc_north_3d ( pt3d, cd_type, psgn) 3047 !!--------------------------------------------------------------------- 3048 !! *** routine mpp_lbc_north_3d *** 3049 !! 3050 !! ** Purpose : 3051 !! Ensure proper north fold horizontal bondary condition in mpp configuration 3052 !! in case of jpn1 > 1 3053 !! 3054 !! ** Method : 3055 !! Gather the 4 northern lines of the global domain on 1 processor and 3056 !! apply lbc north-fold on this sub array. Then scatter the fold array 3057 !! back to the processors. 3058 !! 3059 !! History : 3060 !! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north 3061 !! from lbc routine 3062 !! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk 3063 !!---------------------------------------------------------------------- 3064 3065 !! * Arguments 3066 CHARACTER(len=1), INTENT( in ) :: & 2877 SUBROUTINE mpp_lbc_north_3d ( pt3d, cd_type, psgn ) 2878 !!--------------------------------------------------------------------- 2879 !! *** routine mpp_lbc_north_3d *** 2880 !! 2881 !! ** Purpose : 2882 !! Ensure proper north fold horizontal bondary condition in mpp configuration 2883 !! in case of jpn1 > 1 2884 !! 2885 !! ** Method : 2886 !! Gather the 4 northern lines of the global domain on 1 processor and 2887 !! apply lbc north-fold on this sub array. Then scatter the fold array 2888 !! back to the processors. 2889 !! 2890 !! History : 2891 !! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north 2892 !! from lbc routine 2893 !! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk 2894 !!---------------------------------------------------------------------- 2895 !! * Arguments 2896 CHARACTER(len=1), INTENT( in ) :: & 3067 2897 cd_type ! nature of pt3d grid-points 3068 ! ! = T , U , V , F or W gridpoints3069 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &2898 ! ! = T , U , V , F or W gridpoints 2899 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: & 3070 2900 pt3d ! 3D array on which the boundary condition is applied 3071 REAL(wp), INTENT( in ) :: &2901 REAL(wp), INTENT( in ) :: & 3072 2902 psgn ! control of the sign change 3073 ! ! = -1. , the sign is changed if north fold boundary 3074 ! ! = 1. , the sign is kept if north fold boundary 3075 3076 !! * Local declarations 3077 3078 INTEGER :: ji, jj, jk, jr, jproc 3079 INTEGER :: ierr 3080 INTEGER :: ildi,ilei,iilb 3081 INTEGER :: ijpj,ijpjm1,ij,ijt,iju 3082 INTEGER :: itaille 3083 3084 REAL(wp), DIMENSION(jpiglo,4,jpk) :: ztab 3085 REAL(wp), DIMENSION(jpi,4,jpk,jpni) :: znorthgloio 3086 REAL(wp), DIMENSION(jpi,4,jpk) :: znorthloc 3087 !!---------------------------------------------------------------------- 3088 !! OPA 8.5, LODYC-IPSL (2002) 3089 !!---------------------------------------------------------------------- 2903 ! ! = -1. , the sign is changed if north fold boundary 2904 ! ! = 1. , the sign is kept if north fold boundary 2905 2906 !! * Local declarations 2907 INTEGER :: ji, jj, jk, jr, jproc 2908 INTEGER :: ierr 2909 INTEGER :: ildi,ilei,iilb 2910 INTEGER :: ijpj,ijpjm1,ij,ijt,iju 2911 INTEGER :: itaille 2912 REAL(wp), DIMENSION(jpiglo,4,jpk) :: ztab 2913 REAL(wp), DIMENSION(jpi,4,jpk,jpni) :: znorthgloio 2914 REAL(wp), DIMENSION(jpi,4,jpk) :: znorthloc 2915 !!---------------------------------------------------------------------- 2916 3090 2917 ! If we get in this routine it s because : North fold condition and mpp with more 3091 2918 ! than one proc across i : we deal only with the North condition … … 3124 2951 3125 2952 DO jr = 1, ndim_rank_north 3126 jproc =nrank_north(jr)+13127 ildi =nldit (jproc)3128 ilei =nleit (jproc)3129 iilb =nimppt(jproc)3130 DO jk = 1 3131 DO jj =1,43132 DO ji =ildi,ilei3133 ztab(ji+iilb-1,jj,jk) =znorthgloio(ji,jj,jk,jr)2953 jproc = nrank_north(jr) + 1 2954 ildi = nldit (jproc) 2955 ilei = nleit (jproc) 2956 iilb = nimppt(jproc) 2957 DO jk = 1, jpk 2958 DO jj = 1, 4 2959 DO ji = ildi, ilei 2960 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 3134 2961 END DO 3135 2962 END DO … … 3156 2983 SELECT CASE ( cd_type ) 3157 2984 3158 CASE ( 'T' , ' W' )! T-, W-point2985 CASE ( 'T' , 'S' , 'W' ) ! T-, W-point 3159 2986 DO ji = 2, jpiglo 3160 2987 ijt = jpiglo-ji+2 … … 3183 3010 END DO 3184 3011 3185 CASE ( 'F' )! F-point3012 CASE ( 'F' , 'G' ) ! F-point 3186 3013 DO ji = 1, jpiglo-1 3187 3014 iju = jpiglo-ji+1 … … 3199 3026 SELECT CASE ( cd_type ) 3200 3027 3201 CASE ( 'T' , ' W' )! T-, W-point3028 CASE ( 'T' , 'S' , 'W' ) ! T-, W-point 3202 3029 DO ji = 1, jpiglo 3203 3030 ijt = jpiglo-ji+1 … … 3221 3048 END DO 3222 3049 3223 CASE ( 'F' )! F-point3050 CASE ( 'F' , 'G' ) ! F-point 3224 3051 DO ji = 1, jpiglo-1 3225 3052 iju = jpiglo-ji … … 3351 3178 END DO 3352 3179 3353 3354 3355 3180 IF (npolj /= 0 ) THEN 3356 3181 ! Build in proc 0 of ncomm_north the znorthgloio 3357 3182 znorthgloio(:,:,:) = 0_wp 3358 3359 3183 #ifdef key_mpp_shmem 3360 3184 not done : compiler error … … 3363 3187 CALL MPI_GATHER(znorthloc,itaille,MPI_REAL8,znorthgloio,itaille,MPI_REAL8,0,ncomm_north,ierr) 3364 3188 #endif 3365 3366 3189 ENDIF 3367 3190 … … 3727 3550 3728 3551 3729 SUBROUTINE mpplnks( karr ) ! Dummy routine3730 INTEGER, DIMENSION(:,:) :: karr3731 WRITE(*,*) 'mpplnks: You should not have seen this print! error?', karr(1,1)3552 SUBROUTINE mpplnks( parr ) ! Dummy routine 3553 REAL, DIMENSION(:,:) :: parr 3554 WRITE(*,*) 'mpplnks: You should not have seen this print! error?', parr(1,1) 3732 3555 END SUBROUTINE mpplnks 3733 3556 … … 3753 3576 WRITE(*,*) 'mppisl_real: You should not have seen this print! error?', psca 3754 3577 END SUBROUTINE mppisl_real 3578 3579 SUBROUTINE mppstop 3580 WRITE(*,*) 'mppstop: You should not have seen this print! error?' 3581 END SUBROUTINE mppstop 3582 3755 3583 #endif 3756 3584 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.
