- Timestamp:
- 2013-01-23T15:33:04+01:00 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r3680 r3764 17 17 !! - ! 2008 (R. Benshila) add mpp_ini_ice 18 18 !! 3.2 ! 2009 (R. Benshila) SHMEM suppression, north fold in lbc_nfd 19 !! 3.2 ! 2009 (O. Marti) add mpp_ini_znl 19 !! 3.2 ! 2009 (O. Marti) add mpp_ini_znl 20 20 !! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager 21 21 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d', … … 30 30 !! get_unit : give the index of an unused logical unit 31 31 !!---------------------------------------------------------------------- 32 #if defined key_mpp_mpi 32 #if defined key_mpp_mpi 33 33 !!---------------------------------------------------------------------- 34 34 !! 'key_mpp_mpi' MPI massively parallel processing library … … 55 55 !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 56 56 !!---------------------------------------------------------------------- 57 USE dom_oce ! ocean space and time domain 57 USE dom_oce ! ocean space and time domain 58 58 USE lbcnfd ! north fold treatment 59 59 USE in_out_manager ! I/O manager … … 61 61 IMPLICIT NONE 62 62 PRIVATE 63 63 64 64 PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn 65 65 PUBLIC mynode, mppstop, mppsync, mpp_comm_free … … 70 70 PUBLIC mppobc, mpp_ini_ice, mpp_ini_znl 71 71 PUBLIC mppsize 72 PUBLIC mppsend, mpprecv ! needed by ICB routines72 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 73 73 PUBLIC lib_mpp_alloc ! Called in nemogcm.F90 74 74 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d … … 90 90 END INTERFACE 91 91 INTERFACE mpp_lbc_north 92 MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 92 MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 93 93 END INTERFACE 94 94 INTERFACE mpp_minloc … … 98 98 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 99 99 END INTERFACE 100 100 101 101 !! ========================= !! 102 102 !! MPI variable definition !! … … 105 105 INCLUDE 'mpif.h' 106 106 !$AGRIF_END_DO_NOT_TREAT 107 107 108 108 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag 109 109 110 110 INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2) 111 111 112 112 INTEGER :: mppsize ! number of process 113 113 INTEGER :: mpprank ! process number [ 0 - size-1 ] … … 132 132 INTEGER :: ndim_rank_znl ! number of processors on the same zonal average 133 133 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain 134 135 ! North fold condition in mpp_mpi with jpni > 1 136 INTEGER :: ngrp_world ! group ID for the world processors137 INTEGER :: ngrp_opa ! group ID for the opa processors138 INTEGER :: ngrp_north ! group ID for the northern processors (to be fold)139 INTEGER :: ncomm_north ! communicator made by the processors belonging to ngrp_north140 INTEGER :: ndim_rank_north ! number of 'sea' processor in the northern line (can be /= jpni !)141 INTEGER :: njmppmax ! value of njmpp for the processors of the northern line142 INTEGER :: north_root ! number (in the comm_opa) of proc 0 in the northern comm143 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north ! dimension ndim_rank_north134 135 ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) 136 INTEGER, PUBLIC :: ngrp_world ! group ID for the world processors 137 INTEGER, PUBLIC :: ngrp_opa ! group ID for the opa processors 138 INTEGER, PUBLIC :: ngrp_north ! group ID for the northern processors (to be fold) 139 INTEGER, PUBLIC :: ncomm_north ! communicator made by the processors belonging to ngrp_north 140 INTEGER, PUBLIC :: ndim_rank_north ! number of 'sea' processor in the northern line (can be /= jpni !) 141 INTEGER, PUBLIC :: njmppmax ! value of njmpp for the processors of the northern line 142 INTEGER, PUBLIC :: north_root ! number (in the comm_opa) of proc 0 in the northern comm 143 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC :: nrank_north ! dimension ndim_rank_north 144 144 145 145 ! Type of send : standard, buffered, immediate 146 CHARACTER(len=1) 147 LOGICAL , PUBLIC:: l_isend = .FALSE. ! isend use indicator (T if cn_mpi_send='I')148 INTEGER :: nn_buffer = 0 ! size of the buffer in case of mpi_bsend149 146 CHARACTER(len=1), PUBLIC :: cn_mpi_send = 'S' ! type od mpi send/recieve (S=standard, B=bsend, I=isend) 147 LOGICAL, PUBLIC :: l_isend = .FALSE. ! isend use indicator (T if cn_mpi_send='I') 148 INTEGER, PUBLIC :: nn_buffer = 0 ! size of the buffer in case of mpi_bsend 149 150 150 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend 151 151 … … 177 177 ! North fold arrays used to minimise the use of allgather operations. Set in nemo_northcomms (nemogcm) so need to be public 178 178 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 8 ! Assumed maximum number of active neighbours 179 INTEGER, PUBLIC, PARAMETER :: jptyps = 5 ! Number of different neighbour lists to be used for northfold exchanges 179 INTEGER, PUBLIC, PARAMETER :: jptyps = 5 ! Number of different neighbour lists to be used for northfold exchanges 180 180 INTEGER, PUBLIC, DIMENSION (jpmaxngh,jptyps) :: isendto 181 181 INTEGER, PUBLIC, DIMENSION (jptyps) :: nsndto … … 228 228 !!---------------------------------------------------------------------- 229 229 !! *** routine mynode *** 230 !! 230 !! 231 231 !! ** Purpose : Find processor unit 232 232 !!---------------------------------------------------------------------- 233 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 234 INTEGER , INTENT(in ) :: kumnam ! namelist logical unit 235 INTEGER , INTENT(inout) :: kstop ! stop indicator 233 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 234 INTEGER , INTENT(in ) :: kumnam ! namelist logical unit 235 INTEGER , INTENT(inout) :: kstop ! stop indicator 236 236 INTEGER, OPTIONAL , INTENT(in ) :: localComm 237 237 ! … … 257 257 #if defined key_agrif 258 258 IF( .NOT. Agrif_Root() ) THEN 259 jpni = Agrif_Parent(jpni ) 259 jpni = Agrif_Parent(jpni ) 260 260 jpnj = Agrif_Parent(jpnj ) 261 261 jpnij = Agrif_Parent(jpnij) … … 281 281 CALL mpi_initialized ( mpi_was_called, code ) 282 282 IF( code /= MPI_SUCCESS ) THEN 283 DO ji = 1, SIZE(ldtxt) 283 DO ji = 1, SIZE(ldtxt) 284 284 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 285 END DO 285 END DO 286 286 WRITE(*, cform_err) 287 287 WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' … … 296 296 CASE ( 'B' ) ! Buffer mpi send (blocking) 297 297 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 298 IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) 298 IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) 299 299 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 300 300 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 … … 329 329 ENDIF 330 330 331 IF( PRESENT(localComm) ) THEN 331 IF( PRESENT(localComm) ) THEN 332 332 IF( Agrif_Root() ) THEN 333 333 mpi_comm_opa = localComm … … 336 336 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 337 337 IF( code /= MPI_SUCCESS ) THEN 338 DO ji = 1, SIZE(ldtxt) 338 DO ji = 1, SIZE(ldtxt) 339 339 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 340 340 END DO … … 343 343 CALL mpi_abort( mpi_comm_world, code, ierr ) 344 344 ENDIF 345 ENDIF 345 ENDIF 346 346 347 347 CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 348 348 CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) 349 349 mynode = mpprank 350 ! 350 ! 351 351 CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 352 352 ! … … 721 721 !! ** Purpose : Message passing manadgement 722 722 !! 723 !! ** Method : Use mppsend and mpprecv function for passing mask 723 !! ** Method : Use mppsend and mpprecv function for passing mask 724 724 !! between processors following neighboring subdomains. 725 725 !! domain parameters … … 728 728 !! nbondi : mark for "east-west local boundary" 729 729 !! nbondj : mark for "north-south local boundary" 730 !! noea : number for local neighboring processors 730 !! noea : number for local neighboring processors 731 731 !! nowe : number for local neighboring processors 732 732 !! noso : number for local neighboring processors … … 741 741 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 742 742 ! ! = 1. , the sign is kept 743 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 743 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 744 744 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 745 745 !! … … 762 762 DO jk = 1, jpk 763 763 DO jj = nlcj+1, jpj ! added line(s) (inner only) 764 ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk) 764 ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk) 765 765 ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk) 766 766 ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk) … … 773 773 END DO 774 774 ! 775 ELSE ! standard close or cyclic treatment 775 ELSE ! standard close or cyclic treatment 776 776 ! 777 777 ! ! East-West boundaries … … 792 792 ! 2. East and west directions exchange 793 793 ! ------------------------------------ 794 ! we play with the neigbours AND the row number because of the periodicity 794 ! we play with the neigbours AND the row number because of the periodicity 795 795 ! 796 796 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions … … 801 801 t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 802 802 END DO 803 END SELECT 803 END SELECT 804 804 ! 805 805 ! ! Migrations 806 806 imigr = jpreci * jpj * jpk 807 807 ! 808 SELECT CASE ( nbondi ) 808 SELECT CASE ( nbondi ) 809 809 CASE ( -1 ) 810 810 CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) … … 832 832 ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 833 833 END DO 834 CASE ( 0 ) 834 CASE ( 0 ) 835 835 DO jl = 1, jpreci 836 836 ptab(jl ,:,:) = t3we(:,jl,:,2) … … 859 859 imigr = jprecj * jpi * jpk 860 860 ! 861 SELECT CASE ( nbondj ) 861 SELECT CASE ( nbondj ) 862 862 CASE ( -1 ) 863 863 CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) … … 871 871 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 872 872 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 873 CASE ( 1 ) 873 CASE ( 1 ) 874 874 CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 875 875 CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) … … 885 885 ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 886 886 END DO 887 CASE ( 0 ) 887 CASE ( 0 ) 888 888 DO jl = 1, jprecj 889 889 ptab(:,jl ,:) = t3sn(:,jl,:,2) … … 915 915 !!---------------------------------------------------------------------- 916 916 !! *** routine mpp_lnk_2d *** 917 !! 917 !! 918 918 !! ** Purpose : Message passing manadgement for 2d array 919 919 !! 920 !! ** Method : Use mppsend and mpprecv function for passing mask 920 !! ** Method : Use mppsend and mpprecv function for passing mask 921 921 !! between processors following neighboring subdomains. 922 922 !! domain parameters … … 925 925 !! nbondi : mark for "east-west local boundary" 926 926 !! nbondj : mark for "north-south local boundary" 927 !! noea : number for local neighboring processors 927 !! noea : number for local neighboring processors 928 928 !! nowe : number for local neighboring processors 929 929 !! noso : number for local neighboring processors … … 936 936 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 937 937 ! ! = 1. , the sign is kept 938 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 938 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 939 939 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 940 940 !! … … 957 957 ! WARNING pt2d is defined only between nld and nle 958 958 DO jj = nlcj+1, jpj ! added line(s) (inner only) 959 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej) 959 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej) 960 960 pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej) 961 961 pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej) … … 967 967 END DO 968 968 ! 969 ELSE ! standard close or cyclic treatment 969 ELSE ! standard close or cyclic treatment 970 970 ! 971 971 ! ! East-West boundaries … … 986 986 ! 2. East and west directions exchange 987 987 ! ------------------------------------ 988 ! we play with the neigbours AND the row number because of the periodicity 988 ! we play with the neigbours AND the row number because of the periodicity 989 989 ! 990 990 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions … … 1084 1084 pt2d(:,ijhom+jl) = t2ns(:,jl,2) 1085 1085 END DO 1086 CASE ( 1 ) 1086 CASE ( 1 ) 1087 1087 DO jl = 1, jprecj 1088 1088 pt2d(:,jl ) = t2sn(:,jl,2) … … 1112 1112 !! ** Purpose : Message passing manadgement for two 3D arrays 1113 1113 !! 1114 !! ** Method : Use mppsend and mpprecv function for passing mask 1114 !! ** Method : Use mppsend and mpprecv function for passing mask 1115 1115 !! between processors following neighboring subdomains. 1116 1116 !! domain parameters … … 1119 1119 !! nbondi : mark for "east-west local boundary" 1120 1120 !! nbondj : mark for "north-south local boundary" 1121 !! noea : number for local neighboring processors 1121 !! noea : number for local neighboring processors 1122 1122 !! nowe : number for local neighboring processors 1123 1123 !! noso : number for local neighboring processors … … 1127 1127 !! 1128 1128 !!---------------------------------------------------------------------- 1129 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab1 ! first and second 3D array on which 1129 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab1 ! first and second 3D array on which 1130 1130 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab2 ! the boundary condition is applied 1131 CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 and ptab2 arrays 1131 CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 and ptab2 arrays 1132 1132 CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! i.e. grid-points = T , U , V , F or W points 1133 1133 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary … … 1155 1155 ENDIF 1156 1156 1157 1157 1158 1158 ! ! North-South boundaries 1159 1159 IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0.e0 ! south except at F-point … … 1165 1165 ! 2. East and west directions exchange 1166 1166 ! ------------------------------------ 1167 ! we play with the neigbours AND the row number because of the periodicity 1167 ! we play with the neigbours AND the row number because of the periodicity 1168 1168 ! 1169 1169 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions … … 1181 1181 imigr = jpreci * jpj * jpk *2 1182 1182 ! 1183 SELECT CASE ( nbondi ) 1183 SELECT CASE ( nbondi ) 1184 1184 CASE ( -1 ) 1185 1185 CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 ) … … 1208 1208 ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2) 1209 1209 END DO 1210 CASE ( 0 ) 1210 CASE ( 0 ) 1211 1211 DO jl = 1, jpreci 1212 1212 ptab1(jl ,:,:) = t4we(:,jl,:,1,2) … … 1240 1240 imigr = jprecj * jpi * jpk * 2 1241 1241 ! 1242 SELECT CASE ( nbondj ) 1242 SELECT CASE ( nbondj ) 1243 1243 CASE ( -1 ) 1244 1244 CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 ) … … 1252 1252 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1253 1253 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1254 CASE ( 1 ) 1254 CASE ( 1 ) 1255 1255 CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 1256 1256 CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso ) … … 1267 1267 ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2) 1268 1268 END DO 1269 CASE ( 0 ) 1269 CASE ( 0 ) 1270 1270 DO jl = 1, jprecj 1271 1271 ptab1(:,jl ,:) = t4sn(:,jl,:,1,2) … … 1287 1287 ! 1288 1288 SELECT CASE ( jpni ) 1289 CASE ( 1 ) 1289 CASE ( 1 ) 1290 1290 CALL lbc_nfd ( ptab1, cd_type1, psgn ) ! only for northern procs. 1291 1291 CALL lbc_nfd ( ptab2, cd_type2, psgn ) … … 1293 1293 CALL mpp_lbc_north( ptab1, cd_type1, psgn ) ! for all northern procs. 1294 1294 CALL mpp_lbc_north (ptab2, cd_type2, psgn) 1295 END SELECT 1295 END SELECT 1296 1296 ! 1297 1297 ENDIF … … 1303 1303 !!---------------------------------------------------------------------- 1304 1304 !! *** routine mpp_lnk_2d_e *** 1305 !! 1305 !! 1306 1306 !! ** Purpose : Message passing manadgement for 2d array (with halo) 1307 1307 !! 1308 !! ** Method : Use mppsend and mpprecv function for passing mask 1308 !! ** Method : Use mppsend and mpprecv function for passing mask 1309 1309 !! between processors following neighboring subdomains. 1310 1310 !! domain parameters … … 1315 1315 !! nbondi : mark for "east-west local boundary" 1316 1316 !! nbondj : mark for "north-south local boundary" 1317 !! noea : number for local neighboring processors 1317 !! noea : number for local neighboring processors 1318 1318 !! nowe : number for local neighboring processors 1319 1319 !! noso : number for local neighboring processors … … 1351 1351 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jprj : jprecj ) = 0.e0 ! south except at F-point 1352 1352 pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0.e0 ! north 1353 1353 1354 1354 ! ! East-West boundaries 1355 1355 ! !* Cyclic east-west … … 1371 1371 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 1372 1372 CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn ) 1373 END SELECT 1373 END SELECT 1374 1374 ! 1375 1375 ENDIF … … 1377 1377 ! 2. East and west directions exchange 1378 1378 ! ------------------------------------ 1379 ! we play with the neigbours AND the row number because of the periodicity 1379 ! we play with the neigbours AND the row number because of the periodicity 1380 1380 ! 1381 1381 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions … … 1463 1463 ! 1464 1464 ! ! Write Dirichlet lateral conditions 1465 ijhom = nlcj - jprecj 1465 ijhom = nlcj - jprecj 1466 1466 ! 1467 1467 SELECT CASE ( nbondj ) … … 1475 1475 pt2d(:,ijhom+jl ) = r2dns(:,jl,2) 1476 1476 END DO 1477 CASE ( 1 ) 1477 CASE ( 1 ) 1478 1478 DO jl = 1, iprecj 1479 1479 pt2d(:,jl-jprj) = r2dsn(:,jl,2) … … 1487 1487 !!---------------------------------------------------------------------- 1488 1488 !! *** routine mppsend *** 1489 !! 1489 !! 1490 1490 !! ** Purpose : Send messag passing array 1491 1491 !! … … 1523 1523 INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess 1524 1524 INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message 1525 INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number 1525 INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number 1526 1526 !! 1527 1527 INTEGER :: istatus(mpi_status_size) … … 1531 1531 ! 1532 1532 1533 ! If a specific process number has been passed to the receive call, 1533 ! If a specific process number has been passed to the receive call, 1534 1534 ! use that one. Default is to use mpi_any_source 1535 1535 use_source=mpi_any_source … … 1546 1546 !!---------------------------------------------------------------------- 1547 1547 !! *** routine mppgather *** 1548 !! 1549 !! ** Purpose : Transfert between a local subdomain array and a work 1548 !! 1549 !! ** Purpose : Transfert between a local subdomain array and a work 1550 1550 !! array which is distributed following the vertical level. 1551 1551 !! … … 1560 1560 itaille = jpi * jpj 1561 1561 CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , & 1562 & mpi_double_precision, kp , mpi_comm_opa, ierror ) 1562 & mpi_double_precision, kp , mpi_comm_opa, ierror ) 1563 1563 ! 1564 1564 END SUBROUTINE mppgather … … 1569 1569 !! *** routine mppscatter *** 1570 1570 !! 1571 !! ** Purpose : Transfert between awork array which is distributed 1571 !! ** Purpose : Transfert between awork array which is distributed 1572 1572 !! following the vertical level and the local subdomain array. 1573 1573 !! … … 1591 1591 !!---------------------------------------------------------------------- 1592 1592 !! *** routine mppmax_a_int *** 1593 !! 1593 !! 1594 1594 !! ** Purpose : Find maximum value in an integer layout array 1595 1595 !! … … 1597 1597 INTEGER , INTENT(in ) :: kdim ! size of array 1598 1598 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1599 INTEGER , INTENT(in ), OPTIONAL :: kcom ! 1599 INTEGER , INTENT(in ), OPTIONAL :: kcom ! 1600 1600 !! 1601 1601 INTEGER :: ierror, localcomm ! temporary integer … … 1622 1622 INTEGER, INTENT(inout) :: ktab ! ??? 1623 1623 INTEGER, INTENT(in ), OPTIONAL :: kcom ! ??? 1624 !! 1624 !! 1625 1625 INTEGER :: ierror, iwork, localcomm ! temporary integer 1626 1626 !!---------------------------------------------------------------------- 1627 1627 ! 1628 localcomm = mpi_comm_opa 1628 localcomm = mpi_comm_opa 1629 1629 IF( PRESENT(kcom) ) localcomm = kcom 1630 1630 ! … … 1639 1639 !!---------------------------------------------------------------------- 1640 1640 !! *** routine mppmin_a_int *** 1641 !! 1641 !! 1642 1642 !! ** Purpose : Find minimum value in an integer layout array 1643 1643 !! … … 1687 1687 !!---------------------------------------------------------------------- 1688 1688 !! *** routine mppsum_a_int *** 1689 !! 1689 !! 1690 1690 !! ** Purpose : Global integer sum, 1D array case 1691 1691 !! … … 1708 1708 !!---------------------------------------------------------------------- 1709 1709 !! *** routine mppsum_int *** 1710 !! 1710 !! 1711 1711 !! ** Purpose : Global integer sum 1712 1712 !! 1713 1713 !!---------------------------------------------------------------------- 1714 1714 INTEGER, INTENT(inout) :: ktab 1715 !! 1715 !! 1716 1716 INTEGER :: ierror, iwork 1717 1717 !!---------------------------------------------------------------------- … … 1727 1727 !!---------------------------------------------------------------------- 1728 1728 !! *** routine mppmax_a_real *** 1729 !! 1729 !! 1730 1730 !! ** Purpose : Maximum 1731 1731 !! … … 1751 1751 !!---------------------------------------------------------------------- 1752 1752 !! *** routine mppmax_real *** 1753 !! 1753 !! 1754 1754 !! ** Purpose : Maximum 1755 1755 !! … … 1762 1762 !!---------------------------------------------------------------------- 1763 1763 ! 1764 localcomm = mpi_comm_opa 1764 localcomm = mpi_comm_opa 1765 1765 IF( PRESENT(kcom) ) localcomm = kcom 1766 1766 ! … … 1774 1774 !!---------------------------------------------------------------------- 1775 1775 !! *** routine mppmin_a_real *** 1776 !! 1776 !! 1777 1777 !! ** Purpose : Minimum of REAL, array case 1778 1778 !! … … 1786 1786 !!----------------------------------------------------------------------- 1787 1787 ! 1788 localcomm = mpi_comm_opa 1788 localcomm = mpi_comm_opa 1789 1789 IF( PRESENT(kcom) ) localcomm = kcom 1790 1790 ! … … 1798 1798 !!---------------------------------------------------------------------- 1799 1799 !! *** routine mppmin_real *** 1800 !! 1800 !! 1801 1801 !! ** Purpose : minimum of REAL, scalar case 1802 1802 !! 1803 1803 !!----------------------------------------------------------------------- 1804 REAL(wp), INTENT(inout) :: ptab ! 1804 REAL(wp), INTENT(inout) :: ptab ! 1805 1805 INTEGER , INTENT(in ), OPTIONAL :: kcom 1806 1806 !! … … 1810 1810 !!----------------------------------------------------------------------- 1811 1811 ! 1812 localcomm = mpi_comm_opa 1812 localcomm = mpi_comm_opa 1813 1813 IF( PRESENT(kcom) ) localcomm = kcom 1814 1814 ! … … 1822 1822 !!---------------------------------------------------------------------- 1823 1823 !! *** routine mppsum_a_real *** 1824 !! 1824 !! 1825 1825 !! ** Purpose : global sum, REAL ARRAY argument case 1826 1826 !! … … 1831 1831 !! 1832 1832 INTEGER :: ierror ! temporary integer 1833 INTEGER :: localcomm 1834 REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace 1833 INTEGER :: localcomm 1834 REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace 1835 1835 !!----------------------------------------------------------------------- 1836 1836 ! 1837 localcomm = mpi_comm_opa 1837 localcomm = mpi_comm_opa 1838 1838 IF( PRESENT(kcom) ) localcomm = kcom 1839 1839 ! … … 1847 1847 !!---------------------------------------------------------------------- 1848 1848 !! *** routine mppsum_real *** 1849 !! 1849 !! 1850 1850 !! ** Purpose : global sum, SCALAR argument case 1851 1851 !! … … 1854 1854 INTEGER , INTENT(in ), OPTIONAL :: kcom 1855 1855 !! 1856 INTEGER :: ierror, localcomm 1856 INTEGER :: ierror, localcomm 1857 1857 REAL(wp) :: zwork 1858 1858 !!----------------------------------------------------------------------- 1859 1859 ! 1860 localcomm = mpi_comm_opa 1860 localcomm = mpi_comm_opa 1861 1861 IF( PRESENT(kcom) ) localcomm = kcom 1862 1862 ! … … 1891 1891 1892 1892 END SUBROUTINE mppsum_realdd 1893 1894 1893 1894 1895 1895 SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 1896 1896 !!---------------------------------------------------------------------- … … 1918 1918 1919 1919 END SUBROUTINE mppsum_a_realdd 1920 1920 1921 1921 SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) 1922 1922 !!------------------------------------------------------------------------ … … 2013 2013 REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab 2014 2014 INTEGER , INTENT( out) :: ki, kj ! index of maximum in global frame 2015 !! 2015 !! 2016 2016 INTEGER :: ierror 2017 2017 INTEGER, DIMENSION (2) :: ilocs … … 2052 2052 REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab 2053 2053 INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame 2054 !! 2054 !! 2055 2055 REAL(wp) :: zmax ! local maximum 2056 2056 REAL(wp), DIMENSION(2,1) :: zain, zaout … … 2082 2082 !!---------------------------------------------------------------------- 2083 2083 !! *** routine mppsync *** 2084 !! 2084 !! 2085 2085 !! ** Purpose : Massively parallel processors, synchroneous 2086 2086 !! … … 2097 2097 !!---------------------------------------------------------------------- 2098 2098 !! *** routine mppstop *** 2099 !! 2099 !! 2100 2100 !! ** purpose : Stop massively parallel processors method 2101 2101 !! … … 2113 2113 !!---------------------------------------------------------------------- 2114 2114 !! *** routine mppobc *** 2115 !! 2115 !! 2116 2116 !! ** Purpose : Message passing manadgement for open boundary 2117 2117 !! conditions array … … 2124 2124 !! nbondi : mark for "east-west local boundary" 2125 2125 !! nbondj : mark for "north-south local boundary" 2126 !! noea : number for local neighboring processors 2126 !! noea : number for local neighboring processors 2127 2127 !! nowe : number for local neighboring processors 2128 2128 !! noso : number for local neighboring processors … … 2307 2307 ! 2308 2308 END SUBROUTINE mppobc 2309 2309 2310 2310 2311 2311 SUBROUTINE mpp_comm_free( kcom ) … … 2366 2366 kice = 0 2367 2367 DO jjproc = 1, jpnij 2368 IF( jjproc == narea .AND. pindic .GT. 0 ) kice(jjproc) = 1 2368 IF( jjproc == narea .AND. pindic .GT. 0 ) kice(jjproc) = 1 2369 2369 END DO 2370 2370 ! 2371 2371 zwork = 0 2372 2372 CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr ) 2373 ndim_rank_ice = SUM( zwork ) 2373 ndim_rank_ice = SUM( zwork ) 2374 2374 2375 2375 ! Allocate the right size to nrank_north … … 2377 2377 ALLOCATE( nrank_ice(ndim_rank_ice) ) 2378 2378 ! 2379 ii = 0 2379 ii = 0 2380 2380 nrank_ice = 0 2381 2381 DO jjproc = 1, jpnij 2382 2382 IF( zwork(jjproc) == 1) THEN 2383 2383 ii = ii + 1 2384 nrank_ice(ii) = jjproc -1 2384 nrank_ice(ii) = jjproc -1 2385 2385 ENDIF 2386 2386 END DO … … 2464 2464 IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl) 2465 2465 ALLOCATE(nrank_znl(ndim_rank_znl)) 2466 ii = 0 2466 ii = 0 2467 2467 nrank_znl (:) = 0 2468 2468 DO jproc=1,jpnij 2469 2469 IF ( kwork(jproc) == njmpp) THEN 2470 2470 ii = ii + 1 2471 nrank_znl(ii) = jproc -1 2471 nrank_znl(ii) = jproc -1 2472 2472 ENDIF 2473 2473 END DO … … 2493 2493 2494 2494 ! Determines if processor if the first (starting from i=1) on the row 2495 IF ( jpni == 1 ) THEN 2495 IF ( jpni == 1 ) THEN 2496 2496 l_znl_root = .TRUE. 2497 2497 ELSE … … 2511 2511 !! *** routine mpp_ini_north *** 2512 2512 !! 2513 !! ** Purpose : Initialize special communicator for north folding 2513 !! ** Purpose : Initialize special communicator for north folding 2514 2514 !! condition together with global variables needed in the mpp folding 2515 2515 !! … … 2572 2572 !! *** routine mpp_lbc_north_3d *** 2573 2573 !! 2574 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2574 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2575 2575 !! in mpp configuration in case of jpn1 > 1 2576 2576 !! 2577 2577 !! ** Method : North fold condition and mpp with more than one proc 2578 !! in i-direction require a specific treatment. We gather 2578 !! in i-direction require a specific treatment. We gather 2579 2579 !! the 4 northern lines of the global domain on 1 processor 2580 2580 !! and apply lbc north-fold on this sub array. Then we … … 2585 2585 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 2586 2586 ! ! = T , U , V , F or W gridpoints 2587 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2587 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2588 2588 !! ! = 1. , the sign is kept 2589 2589 INTEGER :: ji, jj, jr … … 2594 2594 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather 2595 2595 !!---------------------------------------------------------------------- 2596 ! 2596 ! 2597 2597 ijpj = 4 2598 2598 ityp = -1 … … 2609 2609 IF ( l_north_nogather ) THEN 2610 2610 ! 2611 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2611 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2612 2612 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2613 2613 ! … … 2634 2634 ityp = 5 2635 2635 CASE DEFAULT 2636 ityp = -1 ! Set a default value for unsupported types which 2636 ityp = -1 ! Set a default value for unsupported types which 2637 2637 ! will cause a fallback to the mpi_allgather method 2638 2638 END SELECT … … 2683 2683 ! The ztab array has been either: 2684 2684 ! a. Fully populated by the mpi_allgather operation or 2685 ! b. Had the active points for this domain and northern neighbours populated 2685 ! b. Had the active points for this domain and northern neighbours populated 2686 2686 ! by peer to peer exchanges 2687 ! Either way the array may be folded by lbc_nfd and the result for the span of 2687 ! Either way the array may be folded by lbc_nfd and the result for the span of 2688 2688 ! this domain will be identical. 2689 2689 ! … … 2704 2704 !! *** routine mpp_lbc_north_2d *** 2705 2705 !! 2706 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2706 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2707 2707 !! in mpp configuration in case of jpn1 > 1 (for 2d array ) 2708 2708 !! 2709 2709 !! ** Method : North fold condition and mpp with more than one proc 2710 !! in i-direction require a specific treatment. We gather 2710 !! in i-direction require a specific treatment. We gather 2711 2711 !! the 4 northern lines of the global domain on 1 processor 2712 2712 !! and apply lbc north-fold on this sub array. Then we … … 2717 2717 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 2718 2718 ! ! = T , U , V , F or W gridpoints 2719 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2719 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2720 2720 !! ! = 1. , the sign is kept 2721 2721 INTEGER :: ji, jj, jr … … 2741 2741 IF ( l_north_nogather ) THEN 2742 2742 ! 2743 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2743 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2744 2744 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2745 2745 ! … … 2766 2766 ityp = 5 2767 2767 CASE DEFAULT 2768 ityp = -1 ! Set a default value for unsupported types which 2768 ityp = -1 ! Set a default value for unsupported types which 2769 2769 ! will cause a fallback to the mpi_allgather method 2770 2770 END SELECT … … 2816 2816 ! The ztab array has been either: 2817 2817 ! a. Fully populated by the mpi_allgather operation or 2818 ! b. Had the active points for this domain and northern neighbours populated 2818 ! b. Had the active points for this domain and northern neighbours populated 2819 2819 ! by peer to peer exchanges 2820 ! Either way the array may be folded by lbc_nfd and the result for the span of 2820 ! Either way the array may be folded by lbc_nfd and the result for the span of 2821 2821 ! this domain will be identical. 2822 2822 ! … … 2838 2838 !! *** routine mpp_lbc_north_2d *** 2839 2839 !! 2840 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2841 !! in mpp configuration in case of jpn1 > 1 and for 2d 2840 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2841 !! in mpp configuration in case of jpn1 > 1 and for 2d 2842 2842 !! array with outer extra halo 2843 2843 !! 2844 2844 !! ** Method : North fold condition and mpp with more than one proc 2845 !! in i-direction require a specific treatment. We gather 2846 !! the 4+2*jpr2dj northern lines of the global domain on 1 2847 !! processor and apply lbc north-fold on this sub array. 2845 !! in i-direction require a specific treatment. We gather 2846 !! the 4+2*jpr2dj northern lines of the global domain on 1 2847 !! processor and apply lbc north-fold on this sub array. 2848 2848 !! Then we scatter the north fold array back to the processors. 2849 2849 !! … … 2852 2852 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 2853 2853 ! ! = T , U , V , F or W -points 2854 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 2854 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 2855 2855 !! ! north fold, = 1. otherwise 2856 2856 INTEGER :: ji, jj, jr … … 2895 2895 !! Scatter back to pt2d 2896 2896 DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj 2897 ij = ij +1 2897 ij = ij +1 2898 2898 DO ji= 1, nlci 2899 2899 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) … … 3339 3339 !! ** Method :: define buffer size in namelist, if 0 no buffer attachment 3340 3340 !! but classical mpi_init 3341 !! 3342 !! History :: 01/11 :: IDRIS initial version for IBM only 3341 !! 3342 !! History :: 01/11 :: IDRIS initial version for IBM only 3343 3343 !! 08/04 :: R. Benshila, generalisation 3344 3344 !!--------------------------------------------------------------------- 3345 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 3345 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 3346 3346 INTEGER , INTENT(inout) :: ksft 3347 3347 INTEGER , INTENT( out) :: code … … 3352 3352 CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization 3353 3353 IF ( code /= MPI_SUCCESS ) THEN 3354 DO ji = 1, SIZE(ldtxt) 3354 DO ji = 1, SIZE(ldtxt) 3355 3355 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 3356 END DO 3356 END DO 3357 3357 WRITE(*, cform_err) 3358 3358 WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized' … … 3364 3364 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code ) 3365 3365 IF ( code /= MPI_SUCCESS ) THEN 3366 DO ji = 1, SIZE(ldtxt) 3366 DO ji = 1, SIZE(ldtxt) 3367 3367 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 3368 3368 END DO … … 3377 3377 ! Buffer allocation and attachment 3378 3378 ALLOCATE( tampon(nn_buffer), stat = ierr ) 3379 IF( ierr /= 0 ) THEN 3380 DO ji = 1, SIZE(ldtxt) 3379 IF( ierr /= 0 ) THEN 3380 DO ji = 1, SIZE(ldtxt) 3381 3381 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 3382 3382 END DO … … 3457 3457 FUNCTION mynode( ldtxt, kumnam, kstop, localComm ) RESULT (function_value) 3458 3458 INTEGER, OPTIONAL , INTENT(in ) :: localComm 3459 CHARACTER(len=*),DIMENSION(:) :: ldtxt 3459 CHARACTER(len=*),DIMENSION(:) :: ldtxt 3460 3460 INTEGER :: kumnam, kstop 3461 3461 IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) ) function_value = 0 … … 3469 3469 REAL , DIMENSION(:) :: parr 3470 3470 INTEGER :: kdim 3471 INTEGER, OPTIONAL :: kcom 3471 INTEGER, OPTIONAL :: kcom 3472 3472 WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom 3473 3473 END SUBROUTINE mpp_sum_as … … 3476 3476 REAL , DIMENSION(:,:) :: parr 3477 3477 INTEGER :: kdim 3478 INTEGER, OPTIONAL :: kcom 3478 INTEGER, OPTIONAL :: kcom 3479 3479 WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom 3480 3480 END SUBROUTINE mpp_sum_a2s … … 3483 3483 INTEGER, DIMENSION(:) :: karr 3484 3484 INTEGER :: kdim 3485 INTEGER, OPTIONAL :: kcom 3485 INTEGER, OPTIONAL :: kcom 3486 3486 WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom 3487 3487 END SUBROUTINE mpp_sum_ai … … 3489 3489 SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine 3490 3490 REAL :: psca 3491 INTEGER, OPTIONAL :: kcom 3491 INTEGER, OPTIONAL :: kcom 3492 3492 WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom 3493 3493 END SUBROUTINE mpp_sum_s … … 3495 3495 SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine 3496 3496 integer :: kint 3497 INTEGER, OPTIONAL :: kcom 3497 INTEGER, OPTIONAL :: kcom 3498 3498 WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom 3499 3499 END SUBROUTINE mpp_sum_i … … 3504 3504 WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab 3505 3505 END SUBROUTINE mppsum_realdd 3506 3506 3507 3507 SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 3508 3508 INTEGER , INTENT( in ) :: kdim ! size of ytab … … 3515 3515 REAL , DIMENSION(:) :: parr 3516 3516 INTEGER :: kdim 3517 INTEGER, OPTIONAL :: kcom 3517 INTEGER, OPTIONAL :: kcom 3518 3518 WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 3519 3519 END SUBROUTINE mppmax_a_real … … 3521 3521 SUBROUTINE mppmax_real( psca, kcom ) 3522 3522 REAL :: psca 3523 INTEGER, OPTIONAL :: kcom 3523 INTEGER, OPTIONAL :: kcom 3524 3524 WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom 3525 3525 END SUBROUTINE mppmax_real … … 3528 3528 REAL , DIMENSION(:) :: parr 3529 3529 INTEGER :: kdim 3530 INTEGER, OPTIONAL :: kcom 3530 INTEGER, OPTIONAL :: kcom 3531 3531 WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 3532 3532 END SUBROUTINE mppmin_a_real … … 3534 3534 SUBROUTINE mppmin_real( psca, kcom ) 3535 3535 REAL :: psca 3536 INTEGER, OPTIONAL :: kcom 3536 INTEGER, OPTIONAL :: kcom 3537 3537 WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom 3538 3538 END SUBROUTINE mppmin_real … … 3541 3541 INTEGER, DIMENSION(:) :: karr 3542 3542 INTEGER :: kdim 3543 INTEGER, OPTIONAL :: kcom 3543 INTEGER, OPTIONAL :: kcom 3544 3544 WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 3545 3545 END SUBROUTINE mppmax_a_int … … 3547 3547 SUBROUTINE mppmax_int( kint, kcom) 3548 3548 INTEGER :: kint 3549 INTEGER, OPTIONAL :: kcom 3549 INTEGER, OPTIONAL :: kcom 3550 3550 WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom 3551 3551 END SUBROUTINE mppmax_int … … 3554 3554 INTEGER, DIMENSION(:) :: karr 3555 3555 INTEGER :: kdim 3556 INTEGER, OPTIONAL :: kcom 3556 INTEGER, OPTIONAL :: kcom 3557 3557 WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 3558 3558 END SUBROUTINE mppmin_a_int … … 3560 3560 SUBROUTINE mppmin_int( kint, kcom ) 3561 3561 INTEGER :: kint 3562 INTEGER, OPTIONAL :: kcom 3562 INTEGER, OPTIONAL :: kcom 3563 3563 WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom 3564 3564 END SUBROUTINE mppmin_int … … 3647 3647 !! *** ROUTINE stop_opa *** 3648 3648 !! 3649 !! ** Purpose : print in ocean.outpput file a error message and 3649 !! ** Purpose : print in ocean.outpput file a error message and 3650 3650 !! increment the error number (nstop) by one. 3651 3651 !!---------------------------------------------------------------------- … … 3654 3654 !!---------------------------------------------------------------------- 3655 3655 ! 3656 nstop = nstop + 1 3656 nstop = nstop + 1 3657 3657 IF(lwp) THEN 3658 3658 WRITE(numout,cform_err) … … 3686 3686 !! *** ROUTINE stop_warn *** 3687 3687 !! 3688 !! ** Purpose : print in ocean.outpput file a error message and 3688 !! ** Purpose : print in ocean.outpput file a error message and 3689 3689 !! increment the warning number (nwarn) by one. 3690 3690 !!---------------------------------------------------------------------- … … 3692 3692 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 3693 3693 !!---------------------------------------------------------------------- 3694 ! 3695 nwarn = nwarn + 1 3694 ! 3695 nwarn = nwarn + 1 3696 3696 IF(lwp) THEN 3697 3697 WRITE(numout,cform_war) … … 3779 3779 STOP 'ctl_opn bad opening' 3780 3780 ENDIF 3781 3781 3782 3782 END SUBROUTINE ctl_opn 3783 3783 … … 3789 3789 !! ** Purpose : return the index of an unused logical unit 3790 3790 !!---------------------------------------------------------------------- 3791 LOGICAL :: llopn 3791 LOGICAL :: llopn 3792 3792 !!---------------------------------------------------------------------- 3793 3793 !
Note: See TracChangeset
for help on using the changeset viewer.
