Changeset 496 for trunk/NEMO/OFF_SRC
- Timestamp:
- 2006-09-12T12:59:38+02:00 (18 years ago)
- Location:
- trunk/NEMO/OFF_SRC
- Files:
-
- 5 edited
-
eosbn2.F90 (modified) (16 diffs)
-
in_out_manager.F90 (modified) (3 diffs)
-
lbclnk.F90 (modified) (8 diffs)
-
lib_mpp.F90 (modified) (38 diffs)
-
opa.F90 (modified) (3 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/OFF_SRC/eosbn2.F90
r343 r496 20 20 USE in_out_manager ! I/O manager 21 21 USE zdfddm ! vertical physics: double diffusion 22 USE prtctl ! Print control 22 23 23 24 IMPLICIT NONE … … 37 38 38 39 !! * Share module variables 39 INTEGER , PUBLIC :: & !: nam eos : ocean physical parameters40 INTEGER , PUBLIC :: & !: nam_eos : ocean physical parameters 40 41 neos = 0, & !: = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 41 42 neos_init = 0 !: control flag for initialization 42 43 43 REAL(wp), PUBLIC :: & !: nam eos : ocean physical parameters44 REAL(wp), PUBLIC :: & !: nam_eos : ocean physical parameters 44 45 ralpha = 2.0e-4, & !: thermal expension coeff. (linear equation of state) 45 46 rbeta = 7.7e-4 !: saline expension coeff. (linear equation of state) … … 218 219 CASE DEFAULT 219 220 220 IF(lwp) WRITE(numout,cform_err) 221 IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos 222 nstop = nstop + 1 221 WRITE(ctmp1,*) ' bad flag value for neos = ', neos 222 CALL ctl_stop( ctmp1 ) 223 223 224 224 END SELECT 225 226 IF(ln_ctl) THEN 227 CALL prt_ctl(tab3d_1=prd, clinfo1=' eos : ', ovlap=1, kdim=jpk) 228 ENDIF 225 229 226 230 END SUBROUTINE eos_insitu … … 402 406 CASE DEFAULT 403 407 404 IF(lwp) WRITE(numout,cform_err) 405 IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos 406 nstop = nstop + 1 408 WRITE(ctmp1,*) ' bad flag value for neos = ', neos 409 CALL ctl_stop( ctmp1 ) 407 410 408 411 END SELECT 412 413 IF(ln_ctl) THEN 414 CALL prt_ctl(tab3d_1=prd, clinfo1=' eos-p: ', tab3d_2=prhop, clinfo2=' pot : ', ovlap=1, kdim=jpk) 415 ENDIF 409 416 410 417 END SUBROUTINE eos_insitu_pot … … 480 487 DO jj = 1, jpjm1 481 488 !CDIR NOVERRCHK 482 #if defined key_ autotasking489 #if defined key_mpp_omp 483 490 DO ji = 1, jpim1 484 491 #else … … 492 499 DO jj = 1, jpjm1 ! Horizontal slab 493 500 ! ! =============== 494 #if defined key_ autotasking501 #if defined key_mpp_omp 495 502 DO ji = 1, jpim1 496 503 #else … … 547 554 DO jj = 1, jpjm1 ! Horizontal slab 548 555 ! ! =============== 549 #if defined key_ autotasking556 #if defined key_mpp_omp 550 557 DO ji = 1, jpim1 551 558 #else … … 564 571 DO jj = 1, jpjm1 ! Horizontal slab 565 572 ! ! =============== 566 #if defined key_ autotasking573 #if defined key_mpp_omp 567 574 DO ji = 1, jpim1 568 575 #else … … 577 584 CASE DEFAULT 578 585 579 IF(lwp) WRITE(numout,cform_err) 580 IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos 581 nstop = nstop + 1 586 WRITE(ctmp1,*) ' bad flag value for neos = ', neos 587 CALL ctl_stop( ctmp1 ) 582 588 583 589 END SELECT 584 590 591 IF(ln_ctl) CALL prt_ctl(tab2d_1=prd, clinfo1=' eos2d: ') 585 592 586 593 END SUBROUTINE eos_insitu_2d … … 639 646 REAL(wp) :: zds ! temporary scalars 640 647 #endif 648 !!---------------------------------------------------------------------- 649 !! OPA8.5, LODYC-IPSL (2002) 650 !!---------------------------------------------------------------------- 641 651 642 652 ! pn2 : first and last levels … … 748 758 CASE DEFAULT 749 759 750 IF(lwp) WRITE(numout,cform_err) 751 IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos 752 nstop = nstop + 1 760 WRITE(ctmp1,*) ' bad flag value for neos = ', neos 761 CALL ctl_stop( ctmp1 ) 753 762 754 763 END SELECT 755 764 765 IF(ln_ctl) THEN 766 CALL prt_ctl(tab3d_1=pn2, clinfo1=' bn2 : ', ovlap=1, kdim=jpk) 767 #if defined key_zdfddm 768 CALL prt_ctl(tab3d_1=rrau, clinfo1=' rrau : ', ovlap=1, kdim=jpk) 769 #endif 770 ENDIF 771 756 772 END SUBROUTINE eos_bn2 757 773 … … 763 779 !! ** Purpose : initializations for the equation of state 764 780 !! 765 !! ** Method : Read the namelist nam eos781 !! ** Method : Read the namelist nam_eos 766 782 !! 767 783 !! ** Action : blahblah.... … … 770 786 !! 8.5 ! 02-10 (G. Madec) Original code 771 787 !!---------------------------------------------------------------------- 772 NAMELIST/nameos/ neos, ralpha, rbeta 788 NAMELIST/nam_eos/ neos, ralpha, rbeta 789 !!---------------------------------------------------------------------- 790 !! OPA 8.5, LODYC-IPSL (2002) 791 !!---------------------------------------------------------------------- 773 792 774 793 ! set the initialization flag to 1 775 794 neos_init = 1 ! indicate that the initialization has been done 776 795 777 ! namelist nam eos : ocean physical parameters778 779 ! Read Namelist nam eos : equation of state796 ! namelist nam_eos : ocean physical parameters 797 798 ! Read Namelist nam_eos : equation of state 780 799 REWIND( numnam ) 781 READ ( numnam, nam eos )800 READ ( numnam, nam_eos ) 782 801 783 802 ! Control print … … 786 805 WRITE(numout,*) 'eos_init : equation of state' 787 806 WRITE(numout,*) '~~~~~~~~' 788 WRITE(numout,*) ' Namelist nam eos : set eos parameters'807 WRITE(numout,*) ' Namelist nam_eos : set eos parameters' 789 808 WRITE(numout,*) 790 809 WRITE(numout,*) ' flag for eq. of state and N^2 neos = ', neos … … 804 823 805 824 IF(lwp) WRITE(numout,*) ' use of linear eos rho(T) = rau0 * ( 1.0285 - ralpha * T )' 806 IF( lk_zdfddm ) THEN 807 IF(lwp) WRITE(numout,cform_err) 808 IF(lwp) WRITE(numout,*) ' double diffusive mixing parameterization requires', & 809 ' that T and S are used as state variables' 810 nstop = nstop + 1 811 ENDIF 825 IF( lk_zdfddm ) CALL ctl_stop( ' double diffusive mixing parameterization requires', & 826 & ' that T and S are used as state variables' ) 812 827 813 828 CASE ( 2 ) ! Linear formulation function of temperature and salinity … … 817 832 CASE DEFAULT 818 833 819 IF(lwp) WRITE(numout,cform_err) 820 IF(lwp) WRITE(numout,*) ' bad flag value for neos = ', neos 821 nstop = nstop + 1 834 WRITE(ctmp1,*) ' bad flag value for neos = ', neos 835 CALL ctl_stop( ctmp1 ) 822 836 823 837 END SELECT -
trunk/NEMO/OFF_SRC/in_out_manager.F90
r325 r496 6 6 7 7 PUBLIC 8 !!----------------------------------------------------------------------9 !! OPA 9.0 , LOCEAN-IPSL (2005)10 !! $Header$11 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt12 !!----------------------------------------------------------------------13 8 14 9 !!---------------------------------------------------------------------- … … 32 27 ninist = 0 , & !: initial state output flag (0/1) 33 28 nbench = 0 !: benchmark parameter (0/1) 34 !!----------------------------------------------------------------------35 !! Run control36 !!----------------------------------------------------------------------37 29 38 INTEGER :: & !:39 nstop = 0 , & !: e r r o r flag (=number of reason for a40 ! ! prematurely stop the run)41 nwarn = 0 !: w a r n i n g flag (=number of warning42 ! ! found during the run)43 44 45 CHARACTER (len=64) :: & !:46 cform_err="(/,' ===>>> : E R R O R', /,' ===========',/)" , & !:47 cform_war="(/,' ===>>> : W A R N I N G', /,' ===============',/)" !:48 30 !!---------------------------------------------------------------------- 49 31 !! output monitoring 50 32 !! ----------------------------------- 51 52 LOGICAL :: & !:53 lwp , & !: boolean : true on the 1st processor only54 lsp_area = .TRUE. !: to make a control print over a specific area55 33 56 34 INTEGER :: & !: … … 75 53 numnam_ice = 4 , & !: logical unit for ice namelist 76 54 numevo_ice = 17 , & !: logical unit for ice variables (temp. evolution) 55 numice_dmp = 18 , & !: logical unit for ice variables (damping) 77 56 numsol = 25 , & !: logical unit for solver statistics 78 57 numwri = 40 , & !: logical unit for output write 79 58 numisp = 41 , & !: logical unit for island statistics 80 59 numgap = 45 , & !: logical unit for differences diagnostic 81 numwrs = 46 , & !: logical unit for output restart82 numtdt = 62 , & !: logical unit for data temperature83 numsdt = 63 , & !: logical unit for data salinity84 numrnf = 64 , & !: logical unit for runoff data85 numwso = 71 , & !: logical unit for 2d output write86 numwvo = 72 , & !: logical unit for 3d output write87 numsst = 65 , & !: logical unit for surface temperature data88 60 numbol = 67 , & !: logical unit for "bol" diagnostics 89 61 numptr = 68 , & !: logical unit for Poleward TRansports 90 numflo = 69 , &!: logical unit for drifting floats62 numflo = 69 !: logical unit for drifting floats 91 63 ! !: * coupled units 92 numlhf = 71 , & !: unit to transfer fluxes93 numlws = 72 , & !: unit to transfer stress94 numlts = 73 , & !: unit to transfer sst95 numlic = 74 !: unit to transfer ice cover96 64 65 !!---------------------------------------------------------------------- 66 !! Run control 67 !!---------------------------------------------------------------------- 68 69 INTEGER :: & !: 70 nstop = 0 , & !: e r r o r flag (=number of reason for a 71 ! ! prematurely stop the run) 72 nwarn = 0 !: w a r n i n g flag (=number of warning 73 ! ! found during the run) 97 74 98 !! Contral/debugging 99 !! ----------------- 75 76 CHARACTER(LEN=100) :: ctmp1, ctmp2, ctmp3 ! temporary character 77 CHARACTER (len=64) :: & !: 78 cform_err="(/,' ===>>> : E R R O R', /,' ===========',/)" , & !: 79 cform_war="(/,' ===>>> : W A R N I N G', /,' ===============',/)" !: 80 LOGICAL :: & !: 81 lwp , & !: boolean : true on the 1st processor only 82 lsp_area = .TRUE. !: to make a control print over a specific area 83 84 !!------------------------------------------------------------------------ 85 !! Contral/debugging 86 !! ----------------------------------------------------------------------- 87 100 88 REAL(wp) :: & !: 101 89 u_ctl, v_ctl, & !: sum of ua and va trend 102 90 t_ctl, s_ctl !: sum of ta and sa trend 103 91 92 !!---------------------------------------------------------------------- 93 !! OPA 9.0 , LOCEAN-IPSL (2005) 94 !! $Header$ 95 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 96 !!---------------------------------------------------------------------- 97 98 99 CONTAINS 100 101 102 SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5, & 103 & cd6, cd7, cd8, cd9, cd10 ) 104 !!----------------------------------------------------------------------- 105 !! *** ROUTINE stop_opa *** 106 !! 107 !! ** Purpose : ??? 108 !! 109 !!----------------------------------------------------------------------- 110 CHARACTER(len=*),INTENT(in),OPTIONAL :: cd1, cd2, cd3, cd4, cd5, cd6, cd7, cd8, cd9, cd10 111 !!----------------------------------------------------------------------- 112 113 nstop = nstop + 1 114 IF(lwp) THEN 115 WRITE(numout,"(/,' ===>>> : E R R O R', /,' ===========',/)") 116 IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1 117 IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2 118 IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3 119 IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4 120 IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5 121 IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6 122 IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7 123 IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8 124 IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9 125 IF( PRESENT(cd10) ) WRITE(numout,*) cd10 126 ENDIF 127 CALL FLUSH(numout) 128 129 END SUBROUTINE ctl_stop 130 131 132 SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, & 133 & cd6, cd7, cd8, cd9, cd10 ) 134 !!----------------------------------------------------------------------- 135 !! *** ROUTINE stop_opa *** 136 !! 137 !! ** Purpose : ??? 138 !! 139 !!----------------------------------------------------------------------- 140 CHARACTER(len=*),INTENT(in),OPTIONAL :: cd1, cd2, cd3, cd4, cd5, cd6, cd7, cd8, cd9, cd10 141 !!----------------------------------------------------------------------- 142 143 nwarn = nwarn + 1 144 IF(lwp) THEN 145 WRITE(numout,"(/,' ===>>> : W A R N I N G', /,' ===============',/)") 146 IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1 147 IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2 148 IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3 149 IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4 150 IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5 151 IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6 152 IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7 153 IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8 154 IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9 155 IF( PRESENT(cd10) ) WRITE(numout,*) cd10 156 ENDIF 157 CALL FLUSH(numout) 158 159 END SUBROUTINE ctl_warn 160 104 161 END MODULE in_out_manager -
trunk/NEMO/OFF_SRC/lbclnk.F90
r343 r496 19 19 20 20 INTERFACE lbc_lnk 21 MODULE PROCEDURE mpp_lnk_3d , mpp_lnk_2d21 MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d 22 22 END INTERFACE 23 23 … … 49 49 50 50 INTERFACE lbc_lnk 51 MODULE PROCEDURE lbc_lnk_3d , lbc_lnk_2d51 MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d 52 52 END INTERFACE 53 53 … … 62 62 CONTAINS 63 63 64 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn ) 64 SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 65 !!--------------------------------------------------------------------- 66 !! *** ROUTINE lbc_lnk_3d_gather *** 67 !! 68 !! ** Purpose : set lateral boundary conditions (non mpp case) 69 !! 70 !! ** Method : 71 !! 72 !! History : 73 !! ! 97-06 (G. Madec) Original code 74 !! 8.5 ! 02-09 (G. Madec) F90: Free form and module 75 !!---------------------------------------------------------------------- 76 !! * Arguments 77 CHARACTER(len=1), INTENT( in ) :: & 78 cd_type1, cd_type2 ! nature of pt3d grid-points 79 ! ! = T , U , V , F or W gridpoints 80 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: & 81 pt3d1, pt3d2 ! 3D array on which the boundary condition is applied 82 REAL(wp), INTENT( in ) :: & 83 psgn ! control of the sign change 84 ! ! =-1 , the sign is changed if north fold boundary 85 ! ! = 1 , no sign change 86 ! ! = 0 , no sign change and > 0 required (use the inner 87 ! ! row/column if closed boundary) 88 89 90 !! * Local declarations 91 INTEGER :: ji, jk 92 INTEGER :: ijt, iju 93 !!---------------------------------------------------------------------- 94 !! OPA 9.0 , LOCEAN-IPSL (2005) 95 !! $Header$ 96 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 97 !!---------------------------------------------------------------------- 98 99 ! ! =============== 100 DO jk = 1, jpk ! Horizontal slab 101 ! ! =============== 102 103 ! ! East-West boundaries 104 ! ! ==================== 105 SELECT CASE ( nperio ) 106 107 CASE ( 1 , 4 , 6 ) ! * cyclic east-west 108 pt3d1( 1 ,:,jk) = pt3d1(jpim1,:,jk) ! all points 109 pt3d1(jpi,:,jk) = pt3d1( 2 ,:,jk) 110 pt3d2( 1 ,:,jk) = pt3d2(jpim1,:,jk) 111 pt3d2(jpi,:,jk) = pt3d2( 2 ,:,jk) 112 113 CASE DEFAULT ! * closed 114 SELECT CASE ( cd_type1 ) 115 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 116 pt3d1( 1 ,:,jk) = 0.e0 117 pt3d1(jpi,:,jk) = 0.e0 118 CASE ( 'F' ) ! F-point 119 pt3d1(jpi,:,jk) = 0.e0 120 END SELECT 121 SELECT CASE ( cd_type2 ) 122 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 123 pt3d2( 1 ,:,jk) = 0.e0 124 pt3d2(jpi,:,jk) = 0.e0 125 CASE ( 'F' ) ! F-point 126 pt3d2(jpi,:,jk) = 0.e0 127 END SELECT 128 129 END SELECT 130 131 ! ! North-South boundaries 132 ! ! ====================== 133 SELECT CASE ( nperio ) 134 135 CASE ( 2 ) ! * south symmetric 136 137 SELECT CASE ( cd_type1 ) 138 CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points 139 pt3d1(:, 1 ,jk) = pt3d1(:,3,jk) 140 pt3d1(:,jpj,jk) = 0.e0 141 CASE ( 'V' , 'F' ) ! V-, F-points 142 pt3d1(:, 1 ,jk) = psgn * pt3d1(:,2,jk) 143 pt3d1(:,jpj,jk) = 0.e0 144 END SELECT 145 SELECT CASE ( cd_type2 ) 146 CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points 147 pt3d2(:, 1 ,jk) = pt3d2(:,3,jk) 148 pt3d2(:,jpj,jk) = 0.e0 149 CASE ( 'V' , 'F' ) ! V-, F-points 150 pt3d2(:, 1 ,jk) = psgn * pt3d2(:,2,jk) 151 pt3d2(:,jpj,jk) = 0.e0 152 END SELECT 153 154 CASE ( 3 , 4 ) ! * North fold T-point pivot 155 156 pt3d1( 1 ,jpj,jk) = 0.e0 157 pt3d1(jpi,jpj,jk) = 0.e0 158 pt3d2( 1 ,jpj,jk) = 0.e0 159 pt3d2(jpi,jpj,jk) = 0.e0 160 161 SELECT CASE ( cd_type1 ) 162 CASE ( 'T' , 'W' ) ! T-, W-point 163 DO ji = 2, jpi 164 ijt = jpi-ji+2 165 pt3d1(ji, 1 ,jk) = 0.e0 166 pt3d1(ji,jpj,jk) = psgn * pt3d1(ijt,jpj-2,jk) 167 END DO 168 DO ji = jpi/2+1, jpi 169 ijt = jpi-ji+2 170 pt3d1(ji,jpjm1,jk) = psgn * pt3d1(ijt,jpjm1,jk) 171 END DO 172 CASE ( 'U' ) ! U-point 173 DO ji = 1, jpi-1 174 iju = jpi-ji+1 175 pt3d1(ji, 1 ,jk) = 0.e0 176 pt3d1(ji,jpj,jk) = psgn * pt3d1(iju,jpj-2,jk) 177 END DO 178 DO ji = jpi/2, jpi-1 179 iju = jpi-ji+1 180 pt3d1(ji,jpjm1,jk) = psgn * pt3d1(iju,jpjm1,jk) 181 END DO 182 CASE ( 'V' ) ! V-point 183 DO ji = 2, jpi 184 ijt = jpi-ji+2 185 pt3d1(ji, 1 ,jk) = 0.e0 186 pt3d1(ji,jpj-1,jk) = psgn * pt3d1(ijt,jpj-2,jk) 187 pt3d1(ji,jpj ,jk) = psgn * pt3d1(ijt,jpj-3,jk) 188 END DO 189 CASE ( 'F' ) ! F-point 190 DO ji = 1, jpi-1 191 iju = jpi-ji+1 192 pt3d1(ji,jpj-1,jk) = psgn * pt3d1(iju,jpj-2,jk) 193 pt3d1(ji,jpj ,jk) = psgn * pt3d1(iju,jpj-3,jk) 194 END DO 195 END SELECT 196 SELECT CASE ( cd_type2 ) 197 CASE ( 'T' , 'W' ) ! T-, W-point 198 DO ji = 2, jpi 199 ijt = jpi-ji+2 200 pt3d2(ji, 1 ,jk) = 0.e0 201 pt3d2(ji,jpj,jk) = psgn * pt3d2(ijt,jpj-2,jk) 202 END DO 203 DO ji = jpi/2+1, jpi 204 ijt = jpi-ji+2 205 pt3d2(ji,jpjm1,jk) = psgn * pt3d2(ijt,jpjm1,jk) 206 END DO 207 CASE ( 'U' ) ! U-point 208 DO ji = 1, jpi-1 209 iju = jpi-ji+1 210 pt3d2(ji, 1 ,jk) = 0.e0 211 pt3d2(ji,jpj,jk) = psgn * pt3d2(iju,jpj-2,jk) 212 END DO 213 DO ji = jpi/2, jpi-1 214 iju = jpi-ji+1 215 pt3d2(ji,jpjm1,jk) = psgn * pt3d2(iju,jpjm1,jk) 216 END DO 217 CASE ( 'V' ) ! V-point 218 DO ji = 2, jpi 219 ijt = jpi-ji+2 220 pt3d2(ji, 1 ,jk) = 0.e0 221 pt3d2(ji,jpj-1,jk) = psgn * pt3d2(ijt,jpj-2,jk) 222 pt3d2(ji,jpj ,jk) = psgn * pt3d2(ijt,jpj-3,jk) 223 END DO 224 CASE ( 'F' ) ! F-point 225 DO ji = 1, jpi-1 226 iju = jpi-ji+1 227 pt3d2(ji,jpj-1,jk) = psgn * pt3d2(iju,jpj-2,jk) 228 pt3d2(ji,jpj ,jk) = psgn * pt3d2(iju,jpj-3,jk) 229 END DO 230 END SELECT 231 232 CASE ( 5 , 6 ) ! * North fold F-point pivot 233 234 pt3d1( 1 ,jpj,jk) = 0.e0 235 pt3d1(jpi,jpj,jk) = 0.e0 236 pt3d2( 1 ,jpj,jk) = 0.e0 237 pt3d2(jpi,jpj,jk) = 0.e0 238 239 SELECT CASE ( cd_type1 ) 240 CASE ( 'T' , 'W' ) ! T-, W-point 241 DO ji = 1, jpi 242 ijt = jpi-ji+1 243 pt3d1(ji, 1 ,jk) = 0.e0 244 pt3d1(ji,jpj,jk) = psgn * pt3d1(ijt,jpj-1,jk) 245 END DO 246 CASE ( 'U' ) ! U-point 247 DO ji = 1, jpi-1 248 iju = jpi-ji 249 pt3d1(ji, 1 ,jk) = 0.e0 250 pt3d1(ji,jpj,jk) = psgn * pt3d1(iju,jpj-1,jk) 251 END DO 252 CASE ( 'V' ) ! V-point 253 DO ji = 1, jpi 254 ijt = jpi-ji+1 255 pt3d1(ji, 1 ,jk) = 0.e0 256 pt3d1(ji,jpj,jk) = psgn * pt3d1(ijt,jpj-2,jk) 257 END DO 258 DO ji = jpi/2+1, jpi 259 ijt = jpi-ji+1 260 pt3d1(ji,jpjm1,jk) = psgn * pt3d1(ijt,jpjm1,jk) 261 END DO 262 CASE ( 'F' ) ! F-point 263 DO ji = 1, jpi-1 264 iju = jpi-ji 265 pt3d1(ji,jpj ,jk) = psgn * pt3d1(iju,jpj-2,jk) 266 END DO 267 DO ji = jpi/2+1, jpi-1 268 iju = jpi-ji 269 pt3d1(ji,jpjm1,jk) = psgn * pt3d1(iju,jpjm1,jk) 270 END DO 271 END SELECT 272 SELECT CASE ( cd_type2 ) 273 CASE ( 'T' , 'W' ) ! T-, W-point 274 DO ji = 1, jpi 275 ijt = jpi-ji+1 276 pt3d2(ji, 1 ,jk) = 0.e0 277 pt3d2(ji,jpj,jk) = psgn * pt3d2(ijt,jpj-1,jk) 278 END DO 279 CASE ( 'U' ) ! U-point 280 DO ji = 1, jpi-1 281 iju = jpi-ji 282 pt3d2(ji, 1 ,jk) = 0.e0 283 pt3d2(ji,jpj,jk) = psgn * pt3d2(iju,jpj-1,jk) 284 END DO 285 CASE ( 'V' ) ! V-point 286 DO ji = 1, jpi 287 ijt = jpi-ji+1 288 pt3d2(ji, 1 ,jk) = 0.e0 289 pt3d2(ji,jpj,jk) = psgn * pt3d2(ijt,jpj-2,jk) 290 END DO 291 DO ji = jpi/2+1, jpi 292 ijt = jpi-ji+1 293 pt3d2(ji,jpjm1,jk) = psgn * pt3d2(ijt,jpjm1,jk) 294 END DO 295 CASE ( 'F' ) ! F-point 296 DO ji = 1, jpi-1 297 iju = jpi-ji 298 pt3d2(ji,jpj ,jk) = psgn * pt3d2(iju,jpj-2,jk) 299 END DO 300 DO ji = jpi/2+1, jpi-1 301 iju = jpi-ji 302 pt3d2(ji,jpjm1,jk) = psgn * pt3d2(iju,jpjm1,jk) 303 END DO 304 END SELECT 305 306 CASE DEFAULT ! * closed 307 308 SELECT CASE ( cd_type1 ) 309 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 310 pt3d1(:, 1 ,jk) = 0.e0 311 pt3d1(:,jpj,jk) = 0.e0 312 CASE ( 'F' ) ! F-point 313 pt3d1(:,jpj,jk) = 0.e0 314 END SELECT 315 SELECT CASE ( cd_type2 ) 316 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 317 pt3d2(:, 1 ,jk) = 0.e0 318 pt3d2(:,jpj,jk) = 0.e0 319 CASE ( 'F' ) ! F-point 320 pt3d2(:,jpj,jk) = 0.e0 321 END SELECT 322 323 END SELECT 324 ! ! =============== 325 END DO ! End of slab 326 ! ! =============== 327 328 END SUBROUTINE lbc_lnk_3d_gather 329 330 331 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp ) 65 332 !!--------------------------------------------------------------------- 66 333 !! *** ROUTINE lbc_lnk_3d *** … … 86 353 ! ! = 0 , no sign change and > 0 required (use the inner 87 354 ! ! row/column if closed boundary) 355 CHARACTER(len=3), INTENT( in ), OPTIONAL :: & 356 cd_mpp ! fill the overlap area only (here do nothing) 88 357 89 358 !! * Local declarations … … 95 364 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 96 365 !!---------------------------------------------------------------------- 366 367 IF (PRESENT(cd_mpp)) THEN 368 ! only fill the overlap area and extra allows 369 ! this is in mpp case. In this module, just do nothing 370 ELSE 97 371 98 372 ! ! =============== … … 228 502 END DO ! End of slab 229 503 ! ! =============== 504 ENDIF 230 505 END SUBROUTINE lbc_lnk_3d 231 506 232 507 233 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn )508 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp ) 234 509 !!--------------------------------------------------------------------- 235 510 !! *** ROUTINE lbc_lnk_2d *** … … 255 530 REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: & 256 531 pt2d ! 2D array on which the boundary condition is applied 532 CHARACTER(len=3), INTENT( in ), OPTIONAL :: & 533 cd_mpp ! fill the overlap area only (here do nothing) 257 534 258 535 !! * Local declarations 259 536 INTEGER :: ji 260 537 INTEGER :: ijt, iju 261 538 !!---------------------------------------------------------------------- 539 !! OPA 8.5, LODYC-IPSL (2002) 540 !!---------------------------------------------------------------------- 541 542 IF (PRESENT(cd_mpp)) THEN 543 ! only fill the overlap area and extra allows 544 ! this is in mpp case. In this module, just do nothing 545 ELSE 546 262 547 ! ! East-West boundaries 263 548 ! ! ==================== … … 420 705 END SELECT 421 706 707 ENDIF 708 422 709 END SUBROUTINE lbc_lnk_2d 423 710 -
trunk/NEMO/OFF_SRC/lib_mpp.F90
r343 r496 14 14 !! mpp_lnk : generic interface (defined in lbclnk) for : 15 15 !! mpp_lnk_2d, mpp_lnk_3d 16 !! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays 16 17 !! mpp_lnk_e : interface defined in lbclnk 17 18 !! mpplnks … … 28 29 !! mpp_sum : generic interface for : 29 30 !! mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real 31 !! mpp_minloc 32 !! mpp_maxloc 30 33 !! mppsync 31 34 !! mppstop … … 48 51 !!--------------------------------------------------------------------- 49 52 !! * Modules used 50 USE dom_oce ! ocean space and time domain51 USE in_out_manager ! I/O manager53 USE dom_oce ! ocean space and time domain 54 USE in_out_manager ! I/O manager 52 55 53 56 IMPLICIT NONE 57 58 PRIVATE 59 PUBLIC mynode, mpparent, mpp_isl, mpp_min, mpp_max, mpp_sum, mpp_lbc_north 60 PUBLIC mpp_lbc_north_e, mpp_minloc, mpp_maxloc, mpp_lnk_3d, mpp_lnk_2d, mpp_lnk_3d_gather, mpp_lnk_2d_e, mpplnks 61 PUBLIC mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync 54 62 55 63 !! * Interfaces … … 84 92 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag 85 93 86 87 !! * Module variables88 94 !! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,... 89 95 INTEGER, PARAMETER :: & … … 95 101 !! MPI variable definition !! 96 102 !! ========================= !! 103 !$AGRIF_DO_NOT_TREAT 97 104 # include <mpif.h> 105 !$AGRIF_END_DO_NOT_TREAT 98 106 99 107 INTEGER :: & … … 234 242 #endif 235 243 244 REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) :: & 245 t4ns, t4sn ! 3d message passing arrays north-south & south-north 246 REAL(wp), DIMENSION(jpj,jpreci,jpk,2,2) :: & 247 t4ew, t4we ! 3d message passing arrays east-west & west-east 248 REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) :: & 249 t4p1, t4p2 ! 3d message passing arrays north fold 236 250 REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: & 237 251 t3ns, t3sn ! 3d message passing arrays north-south & south-north … … 283 297 WRITE(numout,*) ' mpi send type c_mpi_send = ', c_mpi_send 284 298 285 SELECT CASE ( c_mpi_send ) 286 CASE ( 'S' ) ! Standard mpi send (blocking) 287 WRITE(numout,*) ' Standard blocking mpi send (send)' 288 CALL mpi_init( ierr ) 289 CASE ( 'B' ) ! Buffer mpi send (blocking) 290 WRITE(numout,*) ' Buffer blocking mpi send (bsend)' 291 CALL mpi_init_opa( ierr ) 292 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 293 WRITE(numout,*) ' Immediate non-blocking send (isend)' 294 l_isend = .TRUE. 295 CALL mpi_init( ierr ) 296 CASE DEFAULT 297 WRITE(numout,cform_err) 298 WRITE(numout,*) ' bad value for c_mpi_send = ', c_mpi_send 299 nstop = nstop + 1 300 END SELECT 299 #if defined key_agrif 300 IF( Agrif_Root() ) THEN 301 #endif 302 SELECT CASE ( c_mpi_send ) 303 CASE ( 'S' ) ! Standard mpi send (blocking) 304 WRITE(numout,*) ' Standard blocking mpi send (send)' 305 CALL mpi_init( ierr ) 306 CASE ( 'B' ) ! Buffer mpi send (blocking) 307 WRITE(numout,*) ' Buffer blocking mpi send (bsend)' 308 CALL mpi_init_opa( ierr ) 309 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 310 WRITE(numout,*) ' Immediate non-blocking send (isend)' 311 l_isend = .TRUE. 312 CALL mpi_init( ierr ) 313 CASE DEFAULT 314 WRITE(ctmp1,*) ' bad value for c_mpi_send = ', c_mpi_send 315 CALL ctl_stop( ctmp1 ) 316 END SELECT 317 318 #if defined key_agrif 319 ENDIF 320 #endif 301 321 302 322 CALL mpi_comm_rank( mpi_comm_world, rank, ierr ) … … 337 357 npvm_me = 0 338 358 IF( ndim_mpp > nprocmax ) THEN 339 WRITE(numout,*) 'npvm_mytid=', npvm_mytid, ' too great' 340 STOP ' mynode ' 359 WRITE(ctmp1,*) 'npvm_mytid=', npvm_mytid, ' too great' 360 CALL ctl_stop( ctmp1 ) 361 341 362 ELSE 342 363 npvm_nproc = ndim_mpp … … 456 477 ! --- END receive dimension --- 457 478 IF( ndim_mpp > nprocmax ) THEN 458 WRITE( numout,*) 'mytid=',nt3d_mytid,' too great'459 STOP ' mpparent '479 WRITE(ctmp1,*) 'mytid=',nt3d_mytid,' too great' 480 CALL ctl_stop( ctmp1 ) 460 481 ELSE 461 482 nt3d_nproc = ndim_mpp … … 517 538 #endif 518 539 519 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn )540 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp ) 520 541 !!---------------------------------------------------------------------- 521 542 !! *** routine mpp_lnk_3d *** … … 550 571 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: & 551 572 ptab ! 3D array on which the boundary condition is applied 573 CHARACTER(len=3), INTENT( in ), OPTIONAL :: & 574 cd_mpp ! fill the overlap area only 552 575 553 576 !! * Local variables … … 560 583 ! 1. standard boundary treatment 561 584 ! ------------------------------ 562 ! ! East-West boundaries 563 ! ! ==================== 564 IF( nbondi == 2 .AND. & ! Cyclic east-west 565 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 566 ptab( 1 ,:,:) = ptab(jpim1,:,:) 567 ptab(jpi,:,:) = ptab( 2 ,:,:) 568 569 ELSE ! closed 585 586 IF( PRESENT( cd_mpp ) ) THEN 587 ! only fill extra allows with 1. 588 ptab( 1:nlci, nlcj+1:jpj, :) = 1.e0 589 ptab(nlci+1:jpi , : , :) = 1.e0 590 ELSE 591 592 ! ! East-West boundaries 593 ! ! ==================== 594 IF( nbondi == 2 .AND. & ! Cyclic east-west 595 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 596 ptab( 1 ,:,:) = ptab(jpim1,:,:) 597 ptab(jpi,:,:) = ptab( 2 ,:,:) 598 599 ELSE ! closed 600 SELECT CASE ( cd_type ) 601 CASE ( 'T', 'U', 'V', 'W' ) 602 ptab( 1 :jpreci,:,:) = 0.e0 603 ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0 604 CASE ( 'F' ) 605 ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0 606 END SELECT 607 ENDIF 608 609 ! ! North-South boundaries 610 ! ! ====================== 570 611 SELECT CASE ( cd_type ) 571 612 CASE ( 'T', 'U', 'V', 'W' ) 572 ptab( 1 :jpreci,:,:) = 0.e0573 ptab( nlci-jpreci+1:jpi ,:,:) = 0.e0613 ptab(:, 1 :jprecj,:) = 0.e0 614 ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0 574 615 CASE ( 'F' ) 575 ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0 576 END SELECT 616 ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0 617 END SELECT 618 577 619 ENDIF 578 579 ! ! North-South boundaries580 ! ! ======================581 SELECT CASE ( cd_type )582 CASE ( 'T', 'U', 'V', 'W' )583 ptab(:, 1 :jprecj,:) = 0.e0584 ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0585 CASE ( 'F' )586 ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0587 END SELECT588 589 620 590 621 ! 2. East and west directions exchange … … 749 780 ! ----------------------- 750 781 782 IF (PRESENT(cd_mpp)) THEN 783 ! No north fold treatment (it is assumed to be already OK) 784 785 ELSE 786 751 787 ! 4.1 treatment without exchange (jpni odd) 752 788 ! T-point pivot … … 860 896 END SELECT ! jpni 861 897 898 ENDIF 899 862 900 863 901 ! 5. East and west directions exchange … … 950 988 951 989 952 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn )990 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp ) 953 991 !!---------------------------------------------------------------------- 954 992 !! *** routine mpp_lnk_2d *** … … 982 1020 REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: & 983 1021 pt2d ! 2D array on which the boundary condition is applied 1022 CHARACTER(len=3), INTENT( in ), OPTIONAL :: & 1023 cd_mpp ! fill the overlap area only 984 1024 985 1025 !! * Local variables … … 994 1034 ! 1. standard boundary treatment 995 1035 ! ------------------------------ 996 997 ! ! East-West boundaries 998 ! ! ==================== 999 IF( nbondi == 2 .AND. & ! Cyclic east-west 1000 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1001 pt2d( 1 ,:) = pt2d(jpim1,:) 1002 pt2d(jpi,:) = pt2d( 2 ,:) 1003 1004 ELSE ! ... closed 1036 IF (PRESENT(cd_mpp)) THEN 1037 ! only fill extra allows with 1. 1038 pt2d( 1:nlci, nlcj+1:jpj) = 1.e0 1039 pt2d(nlci+1:jpi , : ) = 1.e0 1040 1041 ELSE 1042 1043 ! ! East-West boundaries 1044 ! ! ==================== 1045 IF( nbondi == 2 .AND. & ! Cyclic east-west 1046 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1047 pt2d( 1 ,:) = pt2d(jpim1,:) 1048 pt2d(jpi,:) = pt2d( 2 ,:) 1049 1050 ELSE ! ... closed 1051 SELECT CASE ( cd_type ) 1052 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 1053 pt2d( 1 :jpreci,:) = 0.e0 1054 pt2d(nlci-jpreci+1:jpi ,:) = 0.e0 1055 CASE ( 'F' ) 1056 pt2d(nlci-jpreci+1:jpi ,:) = 0.e0 1057 END SELECT 1058 ENDIF 1059 1060 ! ! North-South boundaries 1061 ! ! ====================== 1005 1062 SELECT CASE ( cd_type ) 1006 1063 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 1007 pt2d( 1 :jpreci,:) = 0.e01008 pt2d( nlci-jpreci+1:jpi ,:) = 0.e01064 pt2d(:, 1 :jprecj) = 0.e0 1065 pt2d(:,nlcj-jprecj+1:jpj ) = 0.e0 1009 1066 CASE ( 'F' ) 1010 pt2d( nlci-jpreci+1:jpi ,:) = 0.e01067 pt2d(:,nlcj-jprecj+1:jpj ) = 0.e0 1011 1068 END SELECT 1069 1012 1070 ENDIF 1013 1014 ! ! North-South boundaries1015 ! ! ======================1016 SELECT CASE ( cd_type )1017 CASE ( 'T', 'U', 'V', 'W' , 'I' )1018 pt2d(:, 1 :jprecj) = 0.e01019 pt2d(:,nlcj-jprecj+1:jpj ) = 0.e01020 CASE ( 'F' )1021 pt2d(:,nlcj-jprecj+1:jpj ) = 0.e01022 END SELECT1023 1071 1024 1072 … … 1183 1231 ! ----------------------- 1184 1232 1233 IF (PRESENT(cd_mpp)) THEN 1234 ! No north fold treatment (it is assumed to be already OK) 1235 1236 ELSE 1237 1185 1238 ! 4.1 treatment without exchange (jpni odd) 1186 1239 … … 1292 1345 END SELECT ! jpni 1293 1346 1347 ENDIF 1294 1348 1295 1349 ! 5. East and west directions … … 1380 1434 1381 1435 END SUBROUTINE mpp_lnk_2d 1436 1437 1438 SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn ) 1439 !!---------------------------------------------------------------------- 1440 !! *** routine mpp_lnk_3d_gather *** 1441 !! 1442 !! ** Purpose : Message passing manadgement for two 3D arrays 1443 !! 1444 !! ** Method : Use mppsend and mpprecv function for passing mask 1445 !! between processors following neighboring subdomains. 1446 !! domain parameters 1447 !! nlci : first dimension of the local subdomain 1448 !! nlcj : second dimension of the local subdomain 1449 !! nbondi : mark for "east-west local boundary" 1450 !! nbondj : mark for "north-south local boundary" 1451 !! noea : number for local neighboring processors 1452 !! nowe : number for local neighboring processors 1453 !! noso : number for local neighboring processors 1454 !! nono : number for local neighboring processors 1455 !! 1456 !! ** Action : ptab1 and ptab2 with update value at its periphery 1457 !! 1458 !!---------------------------------------------------------------------- 1459 !! * Arguments 1460 CHARACTER(len=1) , INTENT( in ) :: & 1461 cd_type1, cd_type2 ! define the nature of ptab array grid-points 1462 ! ! = T , U , V , F , W points 1463 ! ! = S : T-point, north fold treatment ??? 1464 ! ! = G : F-point, north fold treatment ??? 1465 REAL(wp), INTENT( in ) :: & 1466 psgn ! control of the sign change 1467 ! ! = -1. , the sign is changed if north fold boundary 1468 ! ! = 1. , the sign is kept if north fold boundary 1469 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: & 1470 ptab1, ptab2 ! 3D array on which the boundary condition is applied 1471 1472 !! * Local variables 1473 INTEGER :: ji, jk, jl ! dummy loop indices 1474 INTEGER :: imigr, iihom, ijhom, iloc, ijt, iju ! temporary integers 1475 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1476 INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend 1477 !!---------------------------------------------------------------------- 1478 1479 ! 1. standard boundary treatment 1480 ! ------------------------------ 1481 ! ! East-West boundaries 1482 ! ! ==================== 1483 IF( nbondi == 2 .AND. & ! Cyclic east-west 1484 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1485 ptab1( 1 ,:,:) = ptab1(jpim1,:,:) 1486 ptab1(jpi,:,:) = ptab1( 2 ,:,:) 1487 ptab2( 1 ,:,:) = ptab2(jpim1,:,:) 1488 ptab2(jpi,:,:) = ptab2( 2 ,:,:) 1489 1490 ELSE ! closed 1491 SELECT CASE ( cd_type1 ) 1492 CASE ( 'T', 'U', 'V', 'W' ) 1493 ptab1( 1 :jpreci,:,:) = 0.e0 1494 ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 1495 CASE ( 'F' ) 1496 ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 1497 END SELECT 1498 SELECT CASE ( cd_type2 ) 1499 CASE ( 'T', 'U', 'V', 'W' ) 1500 ptab2( 1 :jpreci,:,:) = 0.e0 1501 ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0 1502 CASE ( 'F' ) 1503 ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0 1504 END SELECT 1505 ENDIF 1506 1507 ! ! North-South boundaries 1508 ! ! ====================== 1509 SELECT CASE ( cd_type1 ) 1510 CASE ( 'T', 'U', 'V', 'W' ) 1511 ptab1(:, 1 :jprecj,:) = 0.e0 1512 ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0 1513 CASE ( 'F' ) 1514 ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0 1515 END SELECT 1516 1517 SELECT CASE ( cd_type2 ) 1518 CASE ( 'T', 'U', 'V', 'W' ) 1519 ptab2(:, 1 :jprecj,:) = 0.e0 1520 ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0 1521 CASE ( 'F' ) 1522 ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0 1523 END SELECT 1524 1525 1526 ! 2. East and west directions exchange 1527 ! ------------------------------------ 1528 1529 ! 2.1 Read Dirichlet lateral conditions 1530 1531 SELECT CASE ( nbondi ) 1532 CASE ( -1, 0, 1 ) ! all exept 2 1533 iihom = nlci-nreci 1534 DO jl = 1, jpreci 1535 t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 1536 t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 1537 t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 1538 t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 1539 END DO 1540 END SELECT 1541 1542 ! 2.2 Migrations 1543 1544 #if defined key_mpp_shmem 1545 !! * SHMEM version 1546 1547 imigr = jpreci * jpj * jpk *2 1548 1549 SELECT CASE ( nbondi ) 1550 CASE ( -1 ) 1551 CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea ) 1552 CASE ( 0 ) 1553 CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe ) 1554 CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea ) 1555 CASE ( 1 ) 1556 CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe ) 1557 END SELECT 1558 1559 CALL barrier() 1560 CALL shmem_udcflush() 1561 1562 #elif defined key_mpp_mpi 1563 !! * Local variables (MPI version) 1564 1565 imigr = jpreci * jpj * jpk *2 1566 1567 SELECT CASE ( nbondi ) 1568 CASE ( -1 ) 1569 CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 ) 1570 CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 1571 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1572 CASE ( 0 ) 1573 CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1574 CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 ) 1575 CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 1576 CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 1577 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1578 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1579 CASE ( 1 ) 1580 CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1581 CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 1582 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1583 END SELECT 1584 #endif 1585 1586 ! 2.3 Write Dirichlet lateral conditions 1587 1588 iihom = nlci-jpreci 1589 1590 SELECT CASE ( nbondi ) 1591 CASE ( -1 ) 1592 DO jl = 1, jpreci 1593 ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2) 1594 ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2) 1595 END DO 1596 CASE ( 0 ) 1597 DO jl = 1, jpreci 1598 ptab1(jl ,:,:) = t4we(:,jl,:,1,2) 1599 ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2) 1600 ptab2(jl ,:,:) = t4we(:,jl,:,2,2) 1601 ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2) 1602 END DO 1603 CASE ( 1 ) 1604 DO jl = 1, jpreci 1605 ptab1(jl ,:,:) = t4we(:,jl,:,1,2) 1606 ptab2(jl ,:,:) = t4we(:,jl,:,2,2) 1607 END DO 1608 END SELECT 1609 1610 1611 ! 3. North and south directions 1612 ! ----------------------------- 1613 1614 ! 3.1 Read Dirichlet lateral conditions 1615 1616 IF( nbondj /= 2 ) THEN 1617 ijhom = nlcj-nrecj 1618 DO jl = 1, jprecj 1619 t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) 1620 t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) 1621 t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) 1622 t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) 1623 END DO 1624 ENDIF 1625 1626 ! 3.2 Migrations 1627 1628 #if defined key_mpp_shmem 1629 !! * SHMEM version 1630 1631 imigr = jprecj * jpi * jpk * 2 1632 1633 SELECT CASE ( nbondj ) 1634 CASE ( -1 ) 1635 CALL shmem_put( t4sn(1,1,1,1,2), t4sn(1,1,1,1,1), imigr, nono ) 1636 CASE ( 0 ) 1637 CALL shmem_put( t4ns(1,1,1,1,2), t4ns(1,1,1,1,1), imigr, noso ) 1638 CALL shmem_put( t4sn(1,1,1,1,2), t4sn(1,1,1,1,1), imigr, nono ) 1639 CASE ( 1 ) 1640 CALL shmem_put( t4ns(1,1,1,1,2), t4ns(1,1,1,1;,1), imigr, noso ) 1641 END SELECT 1642 1643 CALL barrier() 1644 CALL shmem_udcflush() 1645 1646 #elif defined key_mpp_mpi 1647 !! * Local variables (MPI version) 1648 1649 imigr=jprecj * jpi * jpk * 2 1650 1651 SELECT CASE ( nbondj ) 1652 CASE ( -1 ) 1653 CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 1654 CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr ) 1655 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1656 CASE ( 0 ) 1657 CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 1658 CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 1659 CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr ) 1660 CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr ) 1661 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1662 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1663 CASE ( 1 ) 1664 CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 1665 CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr ) 1666 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1667 END SELECT 1668 1669 #endif 1670 1671 ! 3.3 Write Dirichlet lateral conditions 1672 1673 ijhom = nlcj-jprecj 1674 1675 SELECT CASE ( nbondj ) 1676 CASE ( -1 ) 1677 DO jl = 1, jprecj 1678 ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2) 1679 ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2) 1680 END DO 1681 CASE ( 0 ) 1682 DO jl = 1, jprecj 1683 ptab1(:,jl ,:) = t4sn(:,jl,:,1,2) 1684 ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2) 1685 ptab2(:,jl ,:) = t4sn(:,jl,:,2,2) 1686 ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2) 1687 END DO 1688 CASE ( 1 ) 1689 DO jl = 1, jprecj 1690 ptab1(:,jl,:) = t4sn(:,jl,:,1,2) 1691 ptab2(:,jl,:) = t4sn(:,jl,:,2,2) 1692 END DO 1693 END SELECT 1694 1695 1696 ! 4. north fold treatment 1697 ! ----------------------- 1698 1699 ! 4.1 treatment without exchange (jpni odd) 1700 ! T-point pivot 1701 1702 SELECT CASE ( jpni ) 1703 1704 CASE ( 1 ) ! only one proc along I, no mpp exchange 1705 1706 SELECT CASE ( npolj ) 1707 1708 CASE ( 3 , 4 ) ! T pivot 1709 iloc = jpiglo - 2 * ( nimpp - 1 ) 1710 1711 SELECT CASE ( cd_type1 ) 1712 1713 CASE ( 'T' , 'S', 'W' ) 1714 DO jk = 1, jpk 1715 DO ji = 2, nlci 1716 ijt=iloc-ji+2 1717 ptab1(ji,nlcj,jk) = psgn * ptab1(ijt,nlcj-2,jk) 1718 END DO 1719 DO ji = nlci/2+1, nlci 1720 ijt=iloc-ji+2 1721 ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-1,jk) 1722 END DO 1723 END DO 1724 1725 CASE ( 'U' ) 1726 DO jk = 1, jpk 1727 DO ji = 1, nlci-1 1728 iju=iloc-ji+1 1729 ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-2,jk) 1730 END DO 1731 DO ji = nlci/2, nlci-1 1732 iju=iloc-ji+1 1733 ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-1,jk) 1734 END DO 1735 END DO 1736 1737 CASE ( 'V' ) 1738 DO jk = 1, jpk 1739 DO ji = 2, nlci 1740 ijt=iloc-ji+2 1741 ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-2,jk) 1742 ptab1(ji,nlcj ,jk) = psgn * ptab1(ijt,nlcj-3,jk) 1743 END DO 1744 END DO 1745 1746 CASE ( 'F', 'G' ) 1747 DO jk = 1, jpk 1748 DO ji = 1, nlci-1 1749 iju=iloc-ji+1 1750 ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-2,jk) 1751 ptab1(ji,nlcj ,jk) = psgn * ptab1(iju,nlcj-3,jk) 1752 END DO 1753 END DO 1754 1755 END SELECT 1756 1757 SELECT CASE ( cd_type2 ) 1758 1759 CASE ( 'T' , 'S', 'W' ) 1760 DO jk = 1, jpk 1761 DO ji = 2, nlci 1762 ijt=iloc-ji+2 1763 ptab2(ji,nlcj,jk) = psgn * ptab2(ijt,nlcj-2,jk) 1764 END DO 1765 DO ji = nlci/2+1, nlci 1766 ijt=iloc-ji+2 1767 ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-1,jk) 1768 END DO 1769 END DO 1770 1771 CASE ( 'U' ) 1772 DO jk = 1, jpk 1773 DO ji = 1, nlci-1 1774 iju=iloc-ji+1 1775 ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-2,jk) 1776 END DO 1777 DO ji = nlci/2, nlci-1 1778 iju=iloc-ji+1 1779 ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-1,jk) 1780 END DO 1781 END DO 1782 1783 CASE ( 'V' ) 1784 DO jk = 1, jpk 1785 DO ji = 2, nlci 1786 ijt=iloc-ji+2 1787 ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-2,jk) 1788 ptab2(ji,nlcj ,jk) = psgn * ptab2(ijt,nlcj-3,jk) 1789 END DO 1790 END DO 1791 1792 CASE ( 'F', 'G' ) 1793 DO jk = 1, jpk 1794 DO ji = 1, nlci-1 1795 iju=iloc-ji+1 1796 ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-2,jk) 1797 ptab2(ji,nlcj ,jk) = psgn * ptab2(iju,nlcj-3,jk) 1798 END DO 1799 END DO 1800 1801 END SELECT 1802 1803 CASE ( 5 , 6 ) ! F pivot 1804 iloc=jpiglo-2*(nimpp-1) 1805 1806 SELECT CASE ( cd_type1 ) 1807 1808 CASE ( 'T' , 'S', 'W' ) 1809 DO jk = 1, jpk 1810 DO ji = 1, nlci 1811 ijt=iloc-ji+1 1812 ptab1(ji,nlcj,jk) = psgn * ptab1(ijt,nlcj-1,jk) 1813 END DO 1814 END DO 1815 1816 CASE ( 'U' ) 1817 DO jk = 1, jpk 1818 DO ji = 1, nlci-1 1819 iju=iloc-ji 1820 ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-1,jk) 1821 END DO 1822 END DO 1823 1824 CASE ( 'V' ) 1825 DO jk = 1, jpk 1826 DO ji = 1, nlci 1827 ijt=iloc-ji+1 1828 ptab1(ji,nlcj ,jk) = psgn * ptab1(ijt,nlcj-2,jk) 1829 END DO 1830 DO ji = nlci/2+1, nlci 1831 ijt=iloc-ji+1 1832 ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-1,jk) 1833 END DO 1834 END DO 1835 1836 CASE ( 'F', 'G' ) 1837 DO jk = 1, jpk 1838 DO ji = 1, nlci-1 1839 iju=iloc-ji 1840 ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-2,jk) 1841 END DO 1842 DO ji = nlci/2+1, nlci-1 1843 iju=iloc-ji 1844 ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-1,jk) 1845 END DO 1846 END DO 1847 END SELECT ! cd_type1 1848 1849 SELECT CASE ( cd_type2 ) 1850 1851 CASE ( 'T' , 'S', 'W' ) 1852 DO jk = 1, jpk 1853 DO ji = 1, nlci 1854 ijt=iloc-ji+1 1855 ptab2(ji,nlcj,jk) = psgn * ptab2(ijt,nlcj-1,jk) 1856 END DO 1857 END DO 1858 1859 CASE ( 'U' ) 1860 DO jk = 1, jpk 1861 DO ji = 1, nlci-1 1862 iju=iloc-ji 1863 ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-1,jk) 1864 END DO 1865 END DO 1866 1867 CASE ( 'V' ) 1868 DO jk = 1, jpk 1869 DO ji = 1, nlci 1870 ijt=iloc-ji+1 1871 ptab2(ji,nlcj ,jk) = psgn * ptab2(ijt,nlcj-2,jk) 1872 END DO 1873 DO ji = nlci/2+1, nlci 1874 ijt=iloc-ji+1 1875 ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-1,jk) 1876 END DO 1877 END DO 1878 1879 CASE ( 'F', 'G' ) 1880 DO jk = 1, jpk 1881 DO ji = 1, nlci-1 1882 iju=iloc-ji 1883 ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-2,jk) 1884 END DO 1885 DO ji = nlci/2+1, nlci-1 1886 iju=iloc-ji 1887 ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-1,jk) 1888 END DO 1889 END DO 1890 1891 END SELECT ! cd_type2 1892 1893 END SELECT ! npolj 1894 1895 CASE DEFAULT ! more than 1 proc along I 1896 IF ( npolj /= 0 ) THEN 1897 CALL mpp_lbc_north (ptab1, cd_type1, psgn) ! only for northern procs. 1898 CALL mpp_lbc_north (ptab2, cd_type2, psgn) ! only for northern procs. 1899 ENDIF 1900 1901 END SELECT ! jpni 1902 1903 1904 ! 5. East and west directions exchange 1905 ! ------------------------------------ 1906 1907 SELECT CASE ( npolj ) 1908 1909 CASE ( 3, 4, 5, 6 ) 1910 1911 ! 5.1 Read Dirichlet lateral conditions 1912 1913 SELECT CASE ( nbondi ) 1914 1915 CASE ( -1, 0, 1 ) 1916 iihom = nlci-nreci 1917 DO jl = 1, jpreci 1918 t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 1919 t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 1920 t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 1921 t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 1922 END DO 1923 1924 END SELECT 1925 1926 ! 5.2 Migrations 1927 1928 #if defined key_mpp_shmem 1929 !! SHMEM version 1930 1931 imigr = jpreci * jpj * jpk * 2 1932 1933 SELECT CASE ( nbondi ) 1934 CASE ( -1 ) 1935 CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea ) 1936 CASE ( 0 ) 1937 CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe ) 1938 CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea ) 1939 CASE ( 1 ) 1940 CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe ) 1941 END SELECT 1942 1943 CALL barrier() 1944 CALL shmem_udcflush() 1945 1946 #elif defined key_mpp_mpi 1947 !! MPI version 1948 1949 imigr = jpreci * jpj * jpk * 2 1950 1951 SELECT CASE ( nbondi ) 1952 CASE ( -1 ) 1953 CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 ) 1954 CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 1955 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1956 CASE ( 0 ) 1957 CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1958 CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 ) 1959 CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr ) 1960 CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 1961 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1962 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1963 CASE ( 1 ) 1964 CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1965 CALL mpprecv( 2, t4we(1,1,1,1,2), imigr ) 1966 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1967 END SELECT 1968 #endif 1969 1970 ! 5.3 Write Dirichlet lateral conditions 1971 1972 iihom = nlci-jpreci 1973 1974 SELECT CASE ( nbondi) 1975 CASE ( -1 ) 1976 DO jl = 1, jpreci 1977 ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2) 1978 ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2) 1979 END DO 1980 CASE ( 0 ) 1981 DO jl = 1, jpreci 1982 ptab1(jl ,:,:) = t4we(:,jl,:,1,2) 1983 ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2) 1984 ptab2(jl ,:,:) = t4we(:,jl,:,2,2) 1985 ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2) 1986 END DO 1987 CASE ( 1 ) 1988 DO jl = 1, jpreci 1989 ptab1(jl ,:,:) = t4we(:,jl,:,1,2) 1990 ptab2(jl ,:,:) = t4we(:,jl,:,2,2) 1991 END DO 1992 END SELECT 1993 1994 END SELECT ! npolj 1995 1996 END SUBROUTINE mpp_lnk_3d_gather 1382 1997 1383 1998 … … 2291 2906 INTEGER, SAVE :: ibool=0 2292 2907 2293 IF( kdim > jpmppsum ) THEN 2294 WRITE(numout,*) 'mppisl_a_int routine : kdim is too big' 2295 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2296 STOP 'mppisl_a_int' 2297 ENDIF 2908 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppisl_a_int routine : kdim is too big', & 2909 & 'change jpmppsum dimension in mpp.h' ) 2298 2910 2299 2911 DO ji = 1, kdim … … 2409 3021 INTEGER, SAVE :: ibool=0 2410 3022 2411 IF( kdim > jpmppsum ) THEN 2412 WRITE(numout,*) 'mppmin_a_int routine : kdim is too big' 2413 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2414 STOP 'min_a_int' 2415 ENDIF 3023 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmin_a_int routine : kdim is too big', & 3024 & 'change jpmppsum dimension in mpp.h' ) 2416 3025 2417 3026 DO ji = 1, kdim … … 2514 3123 INTEGER, SAVE :: ibool=0 2515 3124 2516 IF( kdim > jpmppsum ) THEN 2517 WRITE(numout,*) 'mppsum_a_int routine : kdim is too big' 2518 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2519 STOP 'mppsum_a_int' 2520 ENDIF 3125 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppsum_a_int routine : kdim is too big', & 3126 & 'change jpmppsum dimension in mpp.h' ) 2521 3127 2522 3128 DO ji = 1, kdim … … 2618 3224 INTEGER, SAVE :: ibool=0 2619 3225 2620 IF( kdim > jpmppsum ) THEN 2621 WRITE(numout,*) 'mppisl_a_real routine : kdim is too big' 2622 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2623 STOP 'mppisl_a_real' 2624 ENDIF 3226 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppisl_a_real routine : kdim is too big', & 3227 & 'change jpmppsum dimension in mpp.h' ) 2625 3228 2626 3229 DO ji = 1, kdim … … 2755 3358 INTEGER, SAVE :: ibool=0 2756 3359 2757 IF( kdim > jpmppsum ) THEN 2758 WRITE(numout,*) 'mppmax_a_real routine : kdim is too big' 2759 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2760 STOP 'mppmax_a_real' 2761 ENDIF 3360 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmax_a_real routine : kdim is too big', & 3361 & 'change jpmppsum dimension in mpp.h' ) 2762 3362 2763 3363 DO ji = 1, kdim … … 2855 3455 INTEGER, SAVE :: ibool=0 2856 3456 2857 IF( kdim > jpmppsum ) THEN 2858 WRITE(numout,*) 'mpprmin routine : kdim is too big' 2859 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2860 STOP 'mpprmin' 2861 ENDIF 3457 IF( kdim > jpmppsum ) CALL ctl_stop( 'mpprmin routine : kdim is too big', & 3458 & 'change jpmppsum dimension in mpp.h' ) 2862 3459 2863 3460 DO ji = 1, kdim … … 2956 3553 INTEGER, SAVE :: ibool=0 2957 3554 2958 IF( kdim > jpmppsum ) THEN 2959 WRITE(numout,*) 'mppsum_a_real routine : kdim is too big' 2960 WRITE(numout,*) 'change jpmppsum dimension in mpp.h' 2961 STOP 'mppsum_a_real' 2962 ENDIF 3555 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppsum_a_real routine : kdim is too big', & 3556 & 'change jpmppsum dimension in mpp.h' ) 2963 3557 2964 3558 DO ji = 1, kdim … … 3054 3648 !!-------------------------------------------------------------------------- 3055 3649 #ifdef key_mpp_shmem 3056 IF (lwp) THEN 3057 WRITE(numout,*) ' mpp_minloc not yet available in SHMEM' 3058 STOP 3059 ENDIF 3650 CALL ctl_stop( ' mpp_minloc not yet available in SHMEM' ) 3060 3651 # elif key_mpp_mpi 3061 3652 !! * Arguments … … 3107 3698 !!-------------------------------------------------------------------------- 3108 3699 #ifdef key_mpp_shmem 3109 IF (lwp) THEN 3110 WRITE(numout,*) ' mpp_minloc not yet available in SHMEM' 3111 STOP 3112 ENDIF 3700 CALL ctl_stop( ' mpp_minloc not yet available in SHMEM' ) 3113 3701 # elif key_mpp_mpi 3114 3702 !! * Arguments … … 3162 3750 !!-------------------------------------------------------------------------- 3163 3751 #ifdef key_mpp_shmem 3164 IF (lwp) THEN 3165 WRITE(numout,*) ' mpp_maxloc not yet available in SHMEM' 3166 STOP 3167 ENDIF 3752 CALL ctl_stop( ' mpp_maxloc not yet available in SHMEM' ) 3168 3753 # elif key_mpp_mpi 3169 3754 !! * Arguments … … 3214 3799 !!-------------------------------------------------------------------------- 3215 3800 #ifdef key_mpp_shmem 3216 IF (lwp) THEN 3217 WRITE(numout,*) ' mpp_maxloc not yet available in SHMEM' 3218 STOP 3219 ENDIF 3801 CALL ctl_stop( ' mpp_maxloc not yet available in SHMEM' ) 3220 3802 # elif key_mpp_mpi 3221 3803 !! * Arguments … … 3363 3945 ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) ) 3364 3946 ELSE 3365 IF(lwp)WRITE(numout,*) 'mppobc: bad ktype' 3366 STOP 'mppobc' 3947 CALL ctl_stop( 'mppobc: bad ktype' ) 3367 3948 ENDIF 3368 3949 … … 3570 4151 !!---------------------------------------------------------------------- 3571 4152 #ifdef key_mpp_shmem 3572 IF (lwp) THEN 3573 WRITE(numout,*) ' mpp_ini_north not available in SHMEM' 3574 STOP 3575 ENDIF 4153 CALL ctl_stop( ' mpp_ini_north not available in SHMEM' ) 3576 4154 # elif key_mpp_mpi 3577 4155 INTEGER :: ierr … … 3909 4487 REAL(wp), DIMENSION(jpi,4,jpni) :: znorthgloio 3910 4488 REAL(wp), DIMENSION(jpi,4) :: znorthloc 3911 4489 !!---------------------------------------------------------------------- 4490 !! OPA 8.5, LODYC-IPSL (2002) 4491 !!---------------------------------------------------------------------- 3912 4492 ! If we get in this routine it s because : North fold condition and mpp with more 3913 4493 ! than one proc across i : we deal only with the North condition … … 4051 4631 ztab( 2 ,ijpj) = 0.e0 4052 4632 DO ji = 2 , jpiglo-1 4053 ijt = jpi - ji + 24633 ijt = jpiglo - ji + 2 4054 4634 ztab(ji,ijpj)= 0.5 * ( ztab(ji,ijpj-1) + psgn * ztab(ijt,ijpj-1) ) 4055 4635 END DO … … 4315 4895 DO jl = 0, jpr2dj 4316 4896 DO ji = 2 , jpiglo-1 4317 ijt = jpi - ji + 24897 ijt = jpiglo - ji + 2 4318 4898 ztab(ji,ijpj+jl)= 0.5 * ( ztab(ji,ijpj-1-jl) + psgn * ztab(ijt,ijpj-1-jl) ) 4319 4899 END DO … … 4396 4976 SUBROUTINE mpi_init_opa(code) 4397 4977 IMPLICIT NONE 4978 4979 !$AGRIF_DO_NOT_TREAT 4398 4980 # include <mpif.h> 4981 !$AGRIF_END_DO_NOT_TREAT 4399 4982 4400 4983 INTEGER :: code,rang … … 4448 5031 4449 5032 END SUBROUTINE mpi_init_opa 4450 4451 5033 4452 5034 #else -
trunk/NEMO/OFF_SRC/opa.F90
r482 r496 79 79 !! * Local declarations 80 80 INTEGER :: istp ! time step index 81 CHARACTER (len=20) :: namelistname 82 CHARACTER (len=28) :: file_out 81 83 CHARACTER (len=64) :: & 82 84 cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing 85 83 86 !!---------------------------------------------------------------------- 84 85 87 86 88 ! Initializations 87 89 ! =============== 88 90 91 file_out = 'ocean.output' 92 89 93 ! open listing and namelist units 90 IF ( numout /= 0 .AND. numout /= 6 ) THEN 91 OPEN( UNIT=numout, FILE='ocean.output', FORM='FORMATTED' ) 92 ENDIF 93 94 OPEN( UNIT=numnam, FILE='namelist', FORM='FORMATTED', STATUS='OLD' ) 95 96 IF(lwp) THEN 94 IF ( numout /= 0 .AND. numout /= 6 ) THEN 95 CALL ctlopn( numout, file_out, 'UNKNOWN', 'FORMATTED', & 96 & 'SEQUENTIAL', 1, numout, .FALSE., 1 ) 97 ENDIF 98 99 namelistname = 'namelist' 100 CALL ctlopn( numnam, namelistname, 'OLD', 'FORMATTED', 'SEQUENTIAL', & 101 & 1, numout, .FALSE., 1 ) 102 103 WRITE(numout,*) 104 WRITE(numout,*) ' L O D Y C - I P S L' 105 WRITE(numout,*) ' O P A model' 106 WRITE(numout,*) ' Ocean General Circulation Model' 107 WRITE(numout,*) ' version OPA 9.0 (2005) ' 108 WRITE(numout,*) 109 WRITE(numout,*) 110 111 ! Nodes selection 112 narea = mynode() 113 narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 ) 114 lwp = narea == 1 115 116 IF( lk_mpp ) THEN 117 CLOSE( numout ) ! standard model output file 118 WRITE(file_out,FMT="('ocean.output_',I4.4)") narea-1 119 IF ( numout /= 0 .AND. numout /= 6 ) THEN 120 CALL ctlopn( numout, file_out, 'UNKNOWN', 'FORMATTED', & 121 & 'SEQUENTIAL', 1, numout, .FALSE., 1 ) 122 ENDIF 123 ! 97 124 WRITE(numout,*) 98 125 WRITE(numout,*) ' L O D Y C - I P S L' 99 126 WRITE(numout,*) ' O P A model' 100 127 WRITE(numout,*) ' Ocean General Circulation Model' 101 WRITE(numout,*) ' version OPA 9.0 (2003)' 128 WRITE(numout,*) ' version OPA 9.0 (2005) ' 129 WRITE(numout,*) ' MPI Ocean output ' 102 130 WRITE(numout,*) 103 ENDIF 104 105 ! Nodes selection 106 narea = mynode() 107 narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 ) 108 lwp = narea == 1 131 WRITE(numout,*) 132 ENDIF 133 109 134 110 135 ! ! ============================== ! … … 135 160 CALL bn2( tn, sn, rn2 ) ! before Brunt-Vaisala frequency 136 161 137 IF( l k_zps ) CALL zps_hde( nit000, tn, sn, rhd, & ! Partial steps: before Horizontal DErivative162 IF( ln_zps ) CALL zps_hde( nit000, tn, sn, rhd, & ! Partial steps: before Horizontal DErivative 138 163 gtu, gsu, gru, & ! of t, s, rd at the bottom ocean level 139 164 gtv, gsv, grv ) … … 152 177 CALL tra_qsr_init ! Solar radiation penetration 153 178 179 #if ! defined key_off_degrad 154 180 CALL ldf_tra_init ! Lateral ocean tracer physics 181 #endif 155 182 156 183 CALL zdf_init ! Vertical ocean physics
Note: See TracChangeset
for help on using the changeset viewer.
