- Timestamp:
- 2018-11-15T17:27:18+01:00 (5 years ago)
- Location:
- NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC
- Files:
-
- 1 added
- 6 edited
-
lbc_lnk_generic.h90 (modified) (1 diff)
-
lbclnk.F90 (modified) (6 diffs)
-
lib_mpp.F90 (modified) (19 diffs)
-
mpp_allreduce_generic.h90 (modified) (2 diffs)
-
mpp_bdy_generic.h90 (modified) (7 diffs)
-
mpp_lnk_generic.h90 (modified) (3 diffs)
-
mpp_loc_generic.h90 (added)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lbc_lnk_generic.h90
r10068 r10314 46 46 47 47 #if defined MULTI 48 SUBROUTINE ROUTINE_LNK( ptab, cd_nat, psgn, kfld, cd_mpp, pval )48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, cd_mpp, pval ) 49 49 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 50 50 #else 51 SUBROUTINE ROUTINE_LNK( ptab, cd_nat, psgn , cd_mpp, pval )51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , cd_mpp, pval ) 52 52 #endif 53 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 53 54 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 54 55 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points -
NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lbclnk.F90
r10068 r10314 90 90 ! 91 91 INTERFACE lbc_bdy_lnk 92 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 92 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d, lbc_bdy_lnk_4d 93 93 END INTERFACE 94 94 ! … … 179 179 !!---------------------------------------------------------------------- 180 180 181 SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 182 !!---------------------------------------------------------------------- 181 SUBROUTINE lbc_bdy_lnk_4d( cdname, pt4d, cd_type, psgn, ib_bdy ) 182 !!---------------------------------------------------------------------- 183 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 184 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt4d ! 3D array on which the lbc is applied 185 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 186 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 187 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 188 !!---------------------------------------------------------------------- 189 CALL lbc_lnk_4d( cdname, pt4d, cd_type, psgn) 190 END SUBROUTINE lbc_bdy_lnk_4d 191 192 SUBROUTINE lbc_bdy_lnk_3d( cdname, pt3d, cd_type, psgn, ib_bdy ) 193 !!---------------------------------------------------------------------- 194 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 183 195 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 184 196 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points … … 186 198 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 187 199 !!---------------------------------------------------------------------- 188 CALL lbc_lnk_3d( pt3d, cd_type, psgn)200 CALL lbc_lnk_3d( cdname, pt3d, cd_type, psgn) 189 201 END SUBROUTINE lbc_bdy_lnk_3d 190 202 191 203 192 SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 193 !!---------------------------------------------------------------------- 204 SUBROUTINE lbc_bdy_lnk_2d( cdname, pt2d, cd_type, psgn, ib_bdy ) 205 !!---------------------------------------------------------------------- 206 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 194 207 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied 195 208 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points … … 197 210 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 198 211 !!---------------------------------------------------------------------- 199 CALL lbc_lnk_2d( pt2d, cd_type, psgn)212 CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn) 200 213 END SUBROUTINE lbc_bdy_lnk_2d 201 214 … … 203 216 !!gm This routine should be removed with an optional halos size added in argument of generic routines 204 217 205 SUBROUTINE lbc_lnk_2d_icb( pt2d, cd_type, psgn, ki, kj ) 206 !!---------------------------------------------------------------------- 218 SUBROUTINE lbc_lnk_2d_icb( cdname, pt2d, cd_type, psgn, ki, kj ) 219 !!---------------------------------------------------------------------- 220 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 207 221 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 208 222 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points … … 210 224 INTEGER , INTENT(in ) :: ki, kj ! sizes of extra halo (not needed in non-mpp) 211 225 !!---------------------------------------------------------------------- 212 CALL lbc_lnk_2d( pt2d, cd_type, psgn )226 CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn ) 213 227 END SUBROUTINE lbc_lnk_2d_icb 214 228 !!gm end -
NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lib_mpp.F90
r10300 r10314 84 84 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 85 85 PUBLIC mpp_ilor 86 PUBLIC mpp_max_multiple87 86 PUBLIC mppscatter, mppgather 88 87 PUBLIC mpp_ini_znl … … 112 111 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 113 112 END INTERFACE 114 INTERFACE mpp_max_multiple115 MODULE PROCEDURE mppmax_real_multiple116 END INTERFACE117 113 118 114 !! ========================= !! … … 163 159 INTEGER, PUBLIC :: ncom_fsbc = 1 !: copy of sbc time step # nn_fsbc 164 160 INTEGER, PUBLIC :: ncom_dttrc = 1 !: copy of top time step # nn_dttrc 161 INTEGER, PUBLIC :: ncom_freq !: frequency of comm diagnostic 165 162 INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE :: ncomm_sequence !: size of communicated arrays (halos) 163 INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 2000 !: max number of communication record 166 164 INTEGER, PUBLIC :: n_sequence_lbc = 0 !: # of communicated arraysvia lbc 167 165 INTEGER, PUBLIC :: n_sequence_glb = 0 !: # of global communications … … 721 719 # undef OPERATION_SUM_DD 722 720 723 SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom ) 724 !!---------------------------------------------------------------------- 725 !! *** routine mppmax_real *** 726 !! 727 !! ** Purpose : Maximum across processor of each element of a 1D arrays 728 !! 729 !!---------------------------------------------------------------------- 730 REAL(wp), DIMENSION(kdim), INTENT(inout) :: pt1d ! 1D arrays 731 INTEGER , INTENT(in ) :: kdim 732 INTEGER , OPTIONAL , INTENT(in ) :: kcom ! local communicator 733 !! 734 INTEGER :: ierror, ilocalcomm 735 REAL(wp), DIMENSION(kdim) :: zwork 736 !!---------------------------------------------------------------------- 737 ilocalcomm = mpi_comm_oce 738 IF( PRESENT(kcom) ) ilocalcomm = kcom 739 ! 740 CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 741 pt1d(:) = zwork(:) 742 ! 743 END SUBROUTINE mppmax_real_multiple 744 745 746 SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) 747 !!------------------------------------------------------------------------ 748 !! *** routine mpp_minloc *** 749 !! 750 !! ** Purpose : Compute the global minimum of an array ptab 751 !! and also give its global position 752 !! 753 !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC 754 !! 755 !!-------------------------------------------------------------------------- 756 REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array 757 REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask 758 REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab 759 INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame 760 ! 761 INTEGER :: ierror 762 INTEGER , DIMENSION(2) :: ilocs 763 REAL(wp) :: zmin ! local minimum 764 REAL(wp), DIMENSION(2,1) :: zain, zaout 765 !!----------------------------------------------------------------------- 766 ! 767 zmin = MINVAL( ptab(:,:) , mask= pmask == 1._wp ) 768 ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp ) 769 ! 770 ki = ilocs(1) + nimpp - 1 771 kj = ilocs(2) + njmpp - 1 772 ! 773 zain(1,:)=zmin 774 zain(2,:)=ki+10000.*kj 775 ! 776 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OCE,ierror) 777 ! 778 pmin = zaout(1,1) 779 kj = INT(zaout(2,1)/10000.) 780 ki = INT(zaout(2,1) - 10000.*kj ) 781 ! 782 END SUBROUTINE mpp_minloc2d 783 784 785 SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk) 786 !!------------------------------------------------------------------------ 787 !! *** routine mpp_minloc *** 788 !! 789 !! ** Purpose : Compute the global minimum of an array ptab 790 !! and also give its global position 791 !! 792 !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC 793 !! 794 !!-------------------------------------------------------------------------- 795 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptab ! Local 2D array 796 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! Local mask 797 REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab 798 INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame 799 ! 800 INTEGER :: ierror 801 REAL(wp) :: zmin ! local minimum 802 INTEGER , DIMENSION(3) :: ilocs 803 REAL(wp), DIMENSION(2,1) :: zain, zaout 804 !!----------------------------------------------------------------------- 805 ! 806 zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 807 ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 808 ! 809 ki = ilocs(1) + nimpp - 1 810 kj = ilocs(2) + njmpp - 1 811 kk = ilocs(3) 812 ! 813 zain(1,:) = zmin 814 zain(2,:) = ki + 10000.*kj + 100000000.*kk 815 ! 816 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OCE,ierror) 817 ! 818 pmin = zaout(1,1) 819 kk = INT( zaout(2,1) / 100000000. ) 820 kj = INT( zaout(2,1) - kk * 100000000. ) / 10000 821 ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. ) 822 ! 823 END SUBROUTINE mpp_minloc3d 824 825 826 SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj ) 827 !!------------------------------------------------------------------------ 828 !! *** routine mpp_maxloc *** 829 !! 830 !! ** Purpose : Compute the global maximum of an array ptab 831 !! and also give its global position 832 !! 833 !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC 834 !! 835 !!-------------------------------------------------------------------------- 836 REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array 837 REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask 838 REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab 839 INTEGER , INTENT( out) :: ki, kj ! index of maximum in global frame 840 !! 841 INTEGER :: ierror 842 INTEGER, DIMENSION (2) :: ilocs 843 REAL(wp) :: zmax ! local maximum 844 REAL(wp), DIMENSION(2,1) :: zain, zaout 845 !!----------------------------------------------------------------------- 846 ! 847 zmax = MAXVAL( ptab(:,:) , mask= pmask == 1._wp ) 848 ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp ) 849 ! 850 ki = ilocs(1) + nimpp - 1 851 kj = ilocs(2) + njmpp - 1 852 ! 853 zain(1,:) = zmax 854 zain(2,:) = ki + 10000. * kj 855 ! 856 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OCE,ierror) 857 ! 858 pmax = zaout(1,1) 859 kj = INT( zaout(2,1) / 10000. ) 860 ki = INT( zaout(2,1) - 10000.* kj ) 861 ! 862 END SUBROUTINE mpp_maxloc2d 863 864 865 SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk ) 866 !!------------------------------------------------------------------------ 867 !! *** routine mpp_maxloc *** 868 !! 869 !! ** Purpose : Compute the global maximum of an array ptab 870 !! and also give its global position 871 !! 872 !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC 873 !! 874 !!-------------------------------------------------------------------------- 875 REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: ptab ! Local 2D array 876 REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: pmask ! Local mask 877 REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab 878 INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame 879 ! 880 INTEGER :: ierror ! local integer 881 REAL(wp) :: zmax ! local maximum 882 REAL(wp), DIMENSION(2,1) :: zain, zaout 883 INTEGER , DIMENSION(3) :: ilocs 884 !!----------------------------------------------------------------------- 885 ! 886 zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 887 ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 888 ! 889 ki = ilocs(1) + nimpp - 1 890 kj = ilocs(2) + njmpp - 1 891 kk = ilocs(3) 892 ! 893 zain(1,:) = zmax 894 zain(2,:) = ki + 10000.*kj + 100000000.*kk 895 ! 896 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OCE,ierror) 897 ! 898 pmax = zaout(1,1) 899 kk = INT( zaout(2,1) / 100000000. ) 900 kj = INT( zaout(2,1) - kk * 100000000. ) / 10000 901 ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. ) 902 ! 903 END SUBROUTINE mpp_maxloc3d 904 721 !!---------------------------------------------------------------------- 722 !! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 723 !! 724 !!---------------------------------------------------------------------- 725 !! 726 # define OPERATION_MINLOC 727 # define DIM_2d 728 # define ROUTINE_LOC mpp_minloc2d 729 # include "mpp_loc_generic.h90" 730 # undef ROUTINE_LOC 731 # undef DIM_2d 732 # define DIM_3d 733 # define ROUTINE_LOC mpp_minloc3d 734 # include "mpp_loc_generic.h90" 735 # undef ROUTINE_LOC 736 # undef DIM_3d 737 # undef OPERATION_MINLOC 738 739 # define OPERATION_MAXLOC 740 # define DIM_2d 741 # define ROUTINE_LOC mpp_maxloc2d 742 # include "mpp_loc_generic.h90" 743 # undef ROUTINE_LOC 744 # undef DIM_2d 745 # define DIM_3d 746 # define ROUTINE_LOC mpp_maxloc3d 747 # include "mpp_loc_generic.h90" 748 # undef ROUTINE_LOC 749 # undef DIM_3d 750 # undef OPERATION_MAXLOC 905 751 906 752 SUBROUTINE mppsync() … … 1247 1093 ! 1248 1094 itaille = jpimax * ( ipj + 2*kextj ) 1095 ! 1096 IF( ln_timing ) CALL tic_tac(.TRUE.) 1249 1097 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, & 1250 1098 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, & 1251 1099 & ncomm_north, ierr ) 1100 ! 1101 IF( ln_timing ) CALL tic_tac(.FALSE.) 1252 1102 ! 1253 1103 DO jr = 1, ndim_rank_north ! recover the global north array … … 1281 1131 1282 1132 1283 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, kexti, kextj )1133 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 1284 1134 !!---------------------------------------------------------------------- 1285 1135 !! *** routine mpp_lnk_2d_icb *** … … 1303 1153 !! nono : number for local neighboring processors 1304 1154 !!---------------------------------------------------------------------- 1155 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 1305 1156 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo 1306 1157 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points … … 1322 1173 iprecj = nn_hls + kextj 1323 1174 1175 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 1324 1176 1325 1177 ! 1. standard boundary treatment … … 1373 1225 ! ! Migrations 1374 1226 imigr = ipreci * ( jpj + 2*kextj ) 1227 ! 1228 IF( ln_timing ) CALL tic_tac(.TRUE.) 1375 1229 ! 1376 1230 SELECT CASE ( nbondi ) … … 1392 1246 END SELECT 1393 1247 ! 1248 IF( ln_timing ) CALL tic_tac(.FALSE.) 1249 ! 1394 1250 ! ! Write Dirichlet lateral conditions 1395 1251 iihom = jpi - nn_hls … … 1426 1282 ! ! Migrations 1427 1283 imigr = iprecj * ( jpi + 2*kexti ) 1284 ! 1285 IF( ln_timing ) CALL tic_tac(.TRUE.) 1428 1286 ! 1429 1287 SELECT CASE ( nbondj ) … … 1445 1303 END SELECT 1446 1304 ! 1305 IF( ln_timing ) CALL tic_tac(.FALSE.) 1306 ! 1447 1307 ! ! Write Dirichlet lateral conditions 1448 1308 ijhom = jpj - nn_hls … … 1466 1326 END SUBROUTINE mpp_lnk_2d_icb 1467 1327 1328 1329 SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb ) 1330 !!---------------------------------------------------------------------- 1331 !! *** routine mpp_report *** 1332 !! 1333 !! ** Purpose : report use of mpp routines per time-setp 1334 !! 1335 !!---------------------------------------------------------------------- 1336 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1337 INTEGER , OPTIONAL, INTENT(in ) :: kpk, kpl, kpf 1338 LOGICAL , OPTIONAL, INTENT(in ) :: ld_lbc, ld_glb 1339 !! 1340 LOGICAL :: ll_lbc, ll_glb 1341 INTEGER :: ji, jj, jk, jh, jf ! dummy loop indices 1342 !!---------------------------------------------------------------------- 1343 ! 1344 ll_lbc = .FALSE. 1345 IF( PRESENT(ld_lbc) ) ll_lbc = ld_lbc 1346 ll_glb = .FALSE. 1347 IF( PRESENT(ld_glb) ) ll_glb = ld_glb 1348 ! 1349 ! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency 1350 ncom_freq = ncom_fsbc * ncom_dttrc 1351 IF( MOD( MAX(ncom_fsbc,ncom_dttrc), MIN(ncom_fsbc,ncom_dttrc) ) == 0 ) ncom_freq = MAX(ncom_fsbc,ncom_dttrc) 1352 ! 1353 IF ( ncom_stp == nit000+ncom_freq ) THEN ! avoid to count extra communications in potential initializations at nit000 1354 IF( ll_lbc ) THEN 1355 IF( .NOT. ALLOCATED(ncomm_sequence) ) ALLOCATE( ncomm_sequence(ncom_rec_max,2) ) 1356 IF( .NOT. ALLOCATED( crname_lbc) ) ALLOCATE( crname_lbc(ncom_rec_max ) ) 1357 n_sequence_lbc = n_sequence_lbc + 1 1358 IF( n_sequence_lbc > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lnk_generic, increase ncom_rec_max' ) ! deadlock 1359 crname_lbc(n_sequence_lbc) = cdname ! keep the name of the calling routine 1360 ncomm_sequence(n_sequence_lbc,1) = kpk*kpl ! size of 3rd and 4th dimensions 1361 ncomm_sequence(n_sequence_lbc,2) = kpf ! number of arrays to be treated (multi) 1362 ENDIF 1363 IF( ll_glb ) THEN 1364 IF( .NOT. ALLOCATED(crname_glb) ) ALLOCATE( crname_glb(ncom_rec_max) ) 1365 n_sequence_glb = n_sequence_glb + 1 1366 IF( n_sequence_glb > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lnk_generic, increase ncom_rec_max' ) ! deadlock 1367 crname_glb(n_sequence_glb) = cdname ! keep the name of the calling routine 1368 ENDIF 1369 ELSE IF ( ncom_stp == nit000+2*ncom_freq ) THEN 1370 CALL ctl_opn( numcom, 'communication_report.txt', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 1371 WRITE(numcom,*) ' ' 1372 WRITE(numcom,*) ' ------------------------------------------------------------' 1373 WRITE(numcom,*) ' Communication pattern report (second oce+sbc+top time step):' 1374 WRITE(numcom,*) ' ------------------------------------------------------------' 1375 WRITE(numcom,*) ' ' 1376 WRITE(numcom,'(A,I4)') ' Exchanged halos : ', n_sequence_lbc 1377 jj = 0; jk = 0; jf = 0; jh = 0 1378 DO ji = 1, n_sequence_lbc 1379 IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1 1380 IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1 1381 IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1 1382 jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2)) 1383 END DO 1384 WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk 1385 WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf 1386 WRITE(numcom,'(A,I3)') ' from which 3D : ', jj 1387 WRITE(numcom,'(A,I10)') ' Array max size : ', jh*jpi*jpj 1388 WRITE(numcom,*) ' ' 1389 WRITE(numcom,*) ' lbc_lnk called' 1390 jj = 1 1391 DO ji = 2, n_sequence_lbc 1392 IF( crname_lbc(ji-1) /= crname_lbc(ji) ) THEN 1393 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(ji-1)) 1394 jj = 0 1395 END IF 1396 jj = jj + 1 1397 END DO 1398 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) 1399 WRITE(numcom,*) ' ' 1400 IF ( n_sequence_glb > 0 ) THEN 1401 WRITE(numcom,'(A,I4)') ' Global communications : ', n_sequence_glb 1402 jj = 1 1403 DO ji = 2, n_sequence_glb 1404 IF( crname_glb(ji-1) /= crname_glb(ji) ) THEN 1405 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(ji-1)) 1406 jj = 0 1407 END IF 1408 jj = jj + 1 1409 END DO 1410 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(n_sequence_glb)) 1411 DEALLOCATE(crname_glb) 1412 ELSE 1413 WRITE(numcom,*) ' No MPI global communication ' 1414 ENDIF 1415 WRITE(numcom,*) ' ' 1416 WRITE(numcom,*) ' -----------------------------------------------' 1417 WRITE(numcom,*) ' ' 1418 DEALLOCATE(ncomm_sequence) 1419 DEALLOCATE(crname_lbc) 1420 ENDIF 1421 END SUBROUTINE mpp_report 1422 1468 1423 1469 1424 SUBROUTINE tic_tac (ld_tic, ld_global) … … 1482 1437 END IF 1483 1438 1484 #if defined key_mpp_mpi1485 1439 IF ( ld_tic ) THEN 1486 1440 tic_wt(ii) = MPI_Wtime() ! start count tic->tac (waiting time) … … 1490 1444 tic_ct = MPI_Wtime() ! start count tac->tic (waiting time) 1491 1445 ENDIF 1492 #endif1493 1446 1494 1447 END SUBROUTINE tic_tac … … 1502 1455 1503 1456 INTERFACE mpp_sum 1504 MODULE PROCEDURE mpp _sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd1457 MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 1505 1458 END INTERFACE 1506 1459 INTERFACE mpp_max … … 1516 1469 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 1517 1470 END INTERFACE 1518 INTERFACE mpp_max_multiple1519 MODULE PROCEDURE mppmax_real_multiple1520 END INTERFACE1521 1471 1522 1472 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag … … 1545 1495 END SUBROUTINE mppsync 1546 1496 1547 SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine 1548 REAL , DIMENSION(:) :: parr 1549 INTEGER :: kdim 1550 INTEGER, OPTIONAL :: kcom 1551 WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom 1552 END SUBROUTINE mpp_sum_as 1553 1554 SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine 1555 REAL , DIMENSION(:,:) :: parr 1556 INTEGER :: kdim 1557 INTEGER, OPTIONAL :: kcom 1558 WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom 1559 END SUBROUTINE mpp_sum_a2s 1560 1561 SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine 1562 INTEGER, DIMENSION(:) :: karr 1563 INTEGER :: kdim 1564 INTEGER, OPTIONAL :: kcom 1565 WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom 1566 END SUBROUTINE mpp_sum_ai 1567 1568 SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine 1569 REAL :: psca 1570 INTEGER, OPTIONAL :: kcom 1571 WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom 1572 END SUBROUTINE mpp_sum_s 1573 1574 SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine 1575 integer :: kint 1576 INTEGER, OPTIONAL :: kcom 1577 WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom 1578 END SUBROUTINE mpp_sum_i 1579 1580 SUBROUTINE mppsum_realdd( ytab, kcom ) 1581 COMPLEX(wp), INTENT(inout) :: ytab ! input scalar 1582 INTEGER , INTENT( in ), OPTIONAL :: kcom 1583 WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab 1584 END SUBROUTINE mppsum_realdd 1585 1586 SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 1587 INTEGER , INTENT( in ) :: kdim ! size of ytab 1588 COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array 1589 INTEGER , INTENT( in ), OPTIONAL :: kcom 1590 WRITE(*,*) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom 1591 END SUBROUTINE mppsum_a_realdd 1592 1593 SUBROUTINE mppmax_a_real( parr, kdim, kcom ) 1594 REAL , DIMENSION(:) :: parr 1595 INTEGER :: kdim 1596 INTEGER, OPTIONAL :: kcom 1597 WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 1598 END SUBROUTINE mppmax_a_real 1599 1600 SUBROUTINE mppmax_real( psca, kcom ) 1601 REAL :: psca 1602 INTEGER, OPTIONAL :: kcom 1603 WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom 1604 END SUBROUTINE mppmax_real 1605 1606 SUBROUTINE mppmin_a_real( parr, kdim, kcom ) 1607 REAL , DIMENSION(:) :: parr 1608 INTEGER :: kdim 1609 INTEGER, OPTIONAL :: kcom 1610 WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 1611 END SUBROUTINE mppmin_a_real 1612 1613 SUBROUTINE mppmin_real( psca, kcom ) 1614 REAL :: psca 1615 INTEGER, OPTIONAL :: kcom 1616 WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom 1617 END SUBROUTINE mppmin_real 1618 1619 SUBROUTINE mppmax_a_int( karr, kdim ,kcom) 1620 INTEGER, DIMENSION(:) :: karr 1621 INTEGER :: kdim 1622 INTEGER, OPTIONAL :: kcom 1623 WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 1624 END SUBROUTINE mppmax_a_int 1625 1626 SUBROUTINE mppmax_int( kint, kcom) 1627 INTEGER :: kint 1628 INTEGER, OPTIONAL :: kcom 1629 WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom 1630 END SUBROUTINE mppmax_int 1631 1632 SUBROUTINE mppmin_a_int( karr, kdim, kcom ) 1633 INTEGER, DIMENSION(:) :: karr 1634 INTEGER :: kdim 1635 INTEGER, OPTIONAL :: kcom 1636 WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 1637 END SUBROUTINE mppmin_a_int 1638 1639 SUBROUTINE mppmin_int( kint, kcom ) 1640 INTEGER :: kint 1641 INTEGER, OPTIONAL :: kcom 1642 WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom 1643 END SUBROUTINE mppmin_int 1644 1645 SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj ) 1646 REAL :: pmin 1647 REAL , DIMENSION (:,:) :: ptab, pmask 1648 INTEGER :: ki, kj 1649 WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1) 1650 END SUBROUTINE mpp_minloc2d 1651 1652 SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk ) 1653 REAL :: pmin 1654 REAL , DIMENSION (:,:,:) :: ptab, pmask 1655 INTEGER :: ki, kj, kk 1656 WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1) 1657 END SUBROUTINE mpp_minloc3d 1658 1659 SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj ) 1660 REAL :: pmax 1661 REAL , DIMENSION (:,:) :: ptab, pmask 1662 INTEGER :: ki, kj 1663 WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1) 1664 END SUBROUTINE mpp_maxloc2d 1665 1666 SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk ) 1667 REAL :: pmax 1668 REAL , DIMENSION (:,:,:) :: ptab, pmask 1669 INTEGER :: ki, kj, kk 1670 WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1) 1671 END SUBROUTINE mpp_maxloc3d 1497 !!---------------------------------------------------------------------- 1498 !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** 1499 !! 1500 !!---------------------------------------------------------------------- 1501 !! 1502 # define OPERATION_MAX 1503 # define INTEGER_TYPE 1504 # define DIM_0d 1505 # define ROUTINE_ALLREDUCE mppmax_int 1506 # include "mpp_allreduce_generic.h90" 1507 # undef ROUTINE_ALLREDUCE 1508 # undef DIM_0d 1509 # define DIM_1d 1510 # define ROUTINE_ALLREDUCE mppmax_a_int 1511 # include "mpp_allreduce_generic.h90" 1512 # undef ROUTINE_ALLREDUCE 1513 # undef DIM_1d 1514 # undef INTEGER_TYPE 1515 ! 1516 # define REAL_TYPE 1517 # define DIM_0d 1518 # define ROUTINE_ALLREDUCE mppmax_real 1519 # include "mpp_allreduce_generic.h90" 1520 # undef ROUTINE_ALLREDUCE 1521 # undef DIM_0d 1522 # define DIM_1d 1523 # define ROUTINE_ALLREDUCE mppmax_a_real 1524 # include "mpp_allreduce_generic.h90" 1525 # undef ROUTINE_ALLREDUCE 1526 # undef DIM_1d 1527 # undef REAL_TYPE 1528 # undef OPERATION_MAX 1529 !!---------------------------------------------------------------------- 1530 !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** 1531 !! 1532 !!---------------------------------------------------------------------- 1533 !! 1534 # define OPERATION_MIN 1535 # define INTEGER_TYPE 1536 # define DIM_0d 1537 # define ROUTINE_ALLREDUCE mppmin_int 1538 # include "mpp_allreduce_generic.h90" 1539 # undef ROUTINE_ALLREDUCE 1540 # undef DIM_0d 1541 # define DIM_1d 1542 # define ROUTINE_ALLREDUCE mppmin_a_int 1543 # include "mpp_allreduce_generic.h90" 1544 # undef ROUTINE_ALLREDUCE 1545 # undef DIM_1d 1546 # undef INTEGER_TYPE 1547 ! 1548 # define REAL_TYPE 1549 # define DIM_0d 1550 # define ROUTINE_ALLREDUCE mppmin_real 1551 # include "mpp_allreduce_generic.h90" 1552 # undef ROUTINE_ALLREDUCE 1553 # undef DIM_0d 1554 # define DIM_1d 1555 # define ROUTINE_ALLREDUCE mppmin_a_real 1556 # include "mpp_allreduce_generic.h90" 1557 # undef ROUTINE_ALLREDUCE 1558 # undef DIM_1d 1559 # undef REAL_TYPE 1560 # undef OPERATION_MIN 1561 1562 !!---------------------------------------------------------------------- 1563 !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** 1564 !! 1565 !! Global sum of 1D array or a variable (integer, real or complex) 1566 !!---------------------------------------------------------------------- 1567 !! 1568 # define OPERATION_SUM 1569 # define INTEGER_TYPE 1570 # define DIM_0d 1571 # define ROUTINE_ALLREDUCE mppsum_int 1572 # include "mpp_allreduce_generic.h90" 1573 # undef ROUTINE_ALLREDUCE 1574 # undef DIM_0d 1575 # define DIM_1d 1576 # define ROUTINE_ALLREDUCE mppsum_a_int 1577 # include "mpp_allreduce_generic.h90" 1578 # undef ROUTINE_ALLREDUCE 1579 # undef DIM_1d 1580 # undef INTEGER_TYPE 1581 ! 1582 # define REAL_TYPE 1583 # define DIM_0d 1584 # define ROUTINE_ALLREDUCE mppsum_real 1585 # include "mpp_allreduce_generic.h90" 1586 # undef ROUTINE_ALLREDUCE 1587 # undef DIM_0d 1588 # define DIM_1d 1589 # define ROUTINE_ALLREDUCE mppsum_a_real 1590 # include "mpp_allreduce_generic.h90" 1591 # undef ROUTINE_ALLREDUCE 1592 # undef DIM_1d 1593 # undef REAL_TYPE 1594 # undef OPERATION_SUM 1595 1596 # define OPERATION_SUM_DD 1597 # define COMPLEX_TYPE 1598 # define DIM_0d 1599 # define ROUTINE_ALLREDUCE mppsum_realdd 1600 # include "mpp_allreduce_generic.h90" 1601 # undef ROUTINE_ALLREDUCE 1602 # undef DIM_0d 1603 # define DIM_1d 1604 # define ROUTINE_ALLREDUCE mppsum_a_realdd 1605 # include "mpp_allreduce_generic.h90" 1606 # undef ROUTINE_ALLREDUCE 1607 # undef DIM_1d 1608 # undef COMPLEX_TYPE 1609 # undef OPERATION_SUM_DD 1610 1611 !!---------------------------------------------------------------------- 1612 !! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 1613 !! 1614 !!---------------------------------------------------------------------- 1615 !! 1616 # define OPERATION_MINLOC 1617 # define DIM_2d 1618 # define ROUTINE_LOC mpp_minloc2d 1619 # include "mpp_loc_generic.h90" 1620 # undef ROUTINE_LOC 1621 # undef DIM_2d 1622 # define DIM_3d 1623 # define ROUTINE_LOC mpp_minloc3d 1624 # include "mpp_loc_generic.h90" 1625 # undef ROUTINE_LOC 1626 # undef DIM_3d 1627 # undef OPERATION_MINLOC 1628 1629 # define OPERATION_MAXLOC 1630 # define DIM_2d 1631 # define ROUTINE_LOC mpp_maxloc2d 1632 # include "mpp_loc_generic.h90" 1633 # undef ROUTINE_LOC 1634 # undef DIM_2d 1635 # define DIM_3d 1636 # define ROUTINE_LOC mpp_maxloc3d 1637 # include "mpp_loc_generic.h90" 1638 # undef ROUTINE_LOC 1639 # undef DIM_3d 1640 # undef OPERATION_MAXLOC 1672 1641 1673 1642 SUBROUTINE mpp_ilor( ld_switch, ldlast, kcom ) … … 1692 1661 END SUBROUTINE mpp_comm_free 1693 1662 1694 SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom )1695 REAL, DIMENSION(:) :: ptab !1696 INTEGER :: kdim !1697 INTEGER, OPTIONAL :: kcom !1698 WRITE(*,*) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim1699 END SUBROUTINE mppmax_real_multiple1700 1701 1663 #endif 1702 1664 -
NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/mpp_allreduce_generic.h90
r10300 r10314 42 42 INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension 43 43 INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator 44 #if defined key_mpp_mpi 44 45 ! 45 46 INTEGER :: ipi, ii, ierr 46 47 INTEGER :: ierror, ilocalcomm 47 48 TMP_TYPE(:) 49 !!----------------------------------------------------------------------- 50 ! 51 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) 48 52 ! 49 53 ilocalcomm = mpi_comm_oce … … 55 59 ipi = I_SIZE(ptab) ! 1st dimension 56 60 ENDIF 57 61 ! 62 ALLOCATE(work(ipi)) 58 63 IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) 59 ALLOCATE(work(ipi))60 64 CALL mpi_allreduce( ARRAY_IN(:), work, ipi, MPI_TYPE, MPI_OPERATION, ilocalcomm, ierror ) 65 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 61 66 DO ii = 1, ipi 62 67 ARRAY_IN(ii) = work(ii) 63 68 ENDDO 64 69 DEALLOCATE(work) 65 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 66 ! 67 IF( narea == 1 .AND. ncom_stp == nit000+5 ) THEN 68 IF( .NOT. ALLOCATED( crname_glb) ) THEN 69 ALLOCATE( crname_glb(2000), STAT=ierr ) 70 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'allreduce_generic, cannot allocate crname' ) 71 ENDIF 72 n_sequence_glb = n_sequence_glb + 1 73 IF( n_sequence_glb > 2000 ) CALL ctl_stop( 'STOP', 'allreduce_generic, increase crname_glb first dimension' ) 74 crname_glb(n_sequence_glb) = cdname ! keep the name of the calling routine 75 ENDIF 70 #else 71 WRITE(*,*) 'ROUTINE_ALLREDUCE: You should not have seen this print! error?' 72 #endif 76 73 77 74 END SUBROUTINE ROUTINE_ALLREDUCE -
NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/mpp_bdy_generic.h90
r10068 r10314 21 21 # endif 22 22 23 SUBROUTINE ROUTINE_BDY( ptab, cd_nat, psgn , kb_bdy )23 SUBROUTINE ROUTINE_BDY( cdname, ptab, cd_nat, psgn , kb_bdy ) 24 24 !!---------------------------------------------------------------------- 25 25 !! *** routine mpp_lnk_bdy_3d *** … … 42 42 !! 43 43 !!---------------------------------------------------------------------- 44 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 44 45 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 45 46 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points … … 61 62 ipl = L_SIZE(ptab) ! 4th - 62 63 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 64 ! 65 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 63 66 ! 64 67 ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2), & … … 132 135 imigr = nn_hls * jpj * ipk * ipl 133 136 ! 137 IF( ln_timing ) CALL tic_tac(.TRUE.) 138 ! 134 139 SELECT CASE ( nbondi_bdy(IBD_IN(jf)) ) 135 140 CASE ( -1 ) … … 150 155 END SELECT 151 156 ! 157 IF( ln_timing ) CALL tic_tac(.FALSE.) 158 ! 152 159 ! ! Write Dirichlet lateral conditions 153 160 iihom = nlci-nn_hls … … 205 212 imigr = nn_hls * jpi * ipk * ipl 206 213 ! 214 IF( ln_timing ) CALL tic_tac(.TRUE.) 215 ! 207 216 SELECT CASE ( nbondj_bdy(IBD_IN(jf)) ) 208 217 CASE ( -1 ) … … 222 231 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 223 232 END SELECT 233 ! 234 IF( ln_timing ) CALL tic_tac(.FALSE.) 224 235 ! 225 236 ! ! Write Dirichlet lateral conditions -
NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/mpp_lnk_generic.h90
r10297 r10314 63 63 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 64 64 INTEGER :: ierr 65 INTEGER :: icom_freq66 65 REAL(wp) :: zland 67 66 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend … … 73 72 ipl = L_SIZE(ptab) ! 4th - 74 73 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 74 ! 75 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 75 76 ! 76 77 ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2), & … … 151 152 ! 152 153 ! ! Migrations 153 imigr = nn_hls * jpj * ipk * ipl * ipf 154 ! 155 IF( narea == 1 ) THEN 156 157 ! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency 158 icom_freq = ncom_fsbc * ncom_dttrc 159 IF( MOD( MAX(ncom_fsbc,ncom_dttrc), MIN(ncom_fsbc,ncom_dttrc) ) == 0 ) icom_freq = MAX(ncom_fsbc,ncom_dttrc) 160 161 IF ( ncom_stp == nit000+icom_freq ) THEN ! avoid to count extra communications in potential initializations at nit000 162 IF( .NOT. ALLOCATED( ncomm_sequence) ) THEN 163 ALLOCATE( ncomm_sequence(2000,2), STAT=ierr ) 164 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'lnk_generic, cannot allocate ncomm_sequence' ) 165 ALLOCATE( crname_lbc(2000), STAT=ierr ) 166 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'lnk_generic, cannot allocate crname' ) 167 ENDIF 168 n_sequence_lbc = n_sequence_lbc + 1 169 IF( n_sequence_lbc > 2000 ) CALL ctl_stop( 'STOP', 'lnk_generic, increase ncomm_sequence first dimension' ) 170 ncomm_sequence(n_sequence_lbc,1) = ipk*ipl ! size of 3rd and 4th dimensions 171 ncomm_sequence(n_sequence_lbc,2) = ipf ! number of arrays to be treated (multi) 172 crname_lbc (n_sequence_lbc) = cdname ! keep the name of the calling routine 173 ELSE IF ( ncom_stp == (nit000+2*icom_freq) ) THEN 174 IF ( numcom == -1 ) THEN 175 CALL ctl_opn( numcom, 'communication_report.txt', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 176 WRITE(numcom,*) ' ' 177 WRITE(numcom,*) ' ------------------------------------------------------------' 178 WRITE(numcom,*) ' Communication pattern report (second oce+sbc+top time step):' 179 WRITE(numcom,*) ' ------------------------------------------------------------' 180 WRITE(numcom,*) ' ' 181 WRITE(numcom,'(A,I4)') ' Exchanged halos : ', n_sequence_lbc 182 jj = 0; jk = 0; jf = 0; jh = 0 183 DO ji = 1, n_sequence_lbc 184 IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1 185 IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1 186 IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1 187 jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2)) 188 END DO 189 WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk 190 WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf 191 WRITE(numcom,'(A,I3)') ' from which 3D : ', jj 192 WRITE(numcom,'(A,I10)') ' Array max size : ', jh*jpi*jpj 193 WRITE(numcom,*) ' ' 194 WRITE(numcom,*) ' lbc_lnk called' 195 jj = 1 196 DO ji = 2, n_sequence_lbc 197 IF( crname_lbc(ji-1) /= crname_lbc(ji) ) THEN 198 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(ji-1)) 199 jj = 0 200 END IF 201 jj = jj + 1 202 END DO 203 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) 204 WRITE(numcom,*) ' ' 205 IF ( n_sequence_glb > 0 ) THEN 206 WRITE(numcom,'(A,I4)') ' Global communications : ', n_sequence_glb 207 jj = 1 208 DO ji = 2, n_sequence_glb 209 IF( crname_glb(ji-1) /= crname_glb(ji) ) THEN 210 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(ji-1)) 211 jj = 0 212 END IF 213 jj = jj + 1 214 END DO 215 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(n_sequence_glb)) 216 DEALLOCATE(crname_glb) 217 ELSE 218 WRITE(numcom,*) ' No MPI global communication ' 219 ENDIF 220 WRITE(numcom,*) ' ' 221 WRITE(numcom,*) ' -----------------------------------------------' 222 WRITE(numcom,*) ' ' 223 DEALLOCATE(ncomm_sequence) 224 DEALLOCATE(crname_lbc) 225 ENDIF 226 ENDIF 227 ENDIF 154 imigr = nn_hls * jpj * ipk * ipl * ipf 228 155 ! 229 156 IF( ln_timing ) CALL tic_tac(.TRUE.)
Note: See TracChangeset
for help on using the changeset viewer.
