Changeset 3187 for branches/2011/DEV_r2739_STFC_dCSE
- Timestamp:
- 2011-11-28T17:44:46+01:00 (12 years ago)
- Location:
- branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 3 added
- 9 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90
r2528 r3187 28 28 29 29 INTERFACE glob_sum 30 MODULE PROCEDURE glob_sum_2d, glob_sum_3d, glob_sum_2d_a, glob_sum_3d_a30 MODULE PROCEDURE glob_sum_2d, glob_sum_3d, glob_sum_2d_a, glob_sum_3d_a 31 31 END INTERFACE 32 32 … … 39 39 #endif 40 40 41 !! * Control permutation of array indices 42 # include "dom_oce_ftrans.h90" 43 41 44 !!---------------------------------------------------------------------- 42 45 !! NEMO/OPA 3.3 , NEMO Consortium (2010) … … 69 72 !! ** Purpose : perform a masked sum on the inner global domain of a 3D array 70 73 !!----------------------------------------------------------------------- 74 !FTRANS ptab :I :I :z 71 75 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab ! input 3D array 72 76 REAL(wp) :: glob_sum ! global masked sum 73 77 !! 74 78 INTEGER :: jk 79 #if defined key_z_first 80 INTEGER :: ji, jj 81 REAL(wp) :: ztmask 82 #endif 75 83 !!----------------------------------------------------------------------- 76 84 ! 77 85 glob_sum = 0.e0 86 #if defined key_z_first 87 DO jj = 1, jpj 88 DO ji = 1, jpi 89 ztmask = tmask_i(ji,jj) 90 DO jk = 1, jpk 91 glob_sum = glob_sum + ptab(ji,jj,jk)*ztmask 92 END DO 93 END DO 94 END DO 95 #else 78 96 DO jk = 1, jpk 79 97 glob_sum = glob_sum + SUM( ptab(:,:,jk)*tmask_i(:,:) ) 80 98 END DO 99 #endif 81 100 IF( lk_mpp ) CALL mpp_sum( glob_sum ) 82 101 ! … … 107 126 !! ** Purpose : perform a masked sum on the inner global domain of two 3D array 108 127 !!----------------------------------------------------------------------- 128 !FTRANS ptab1 :I :I :z 129 !FTRANS ptab2 :I :I :z 109 130 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 ! input 3D array 110 131 REAL(wp) , DIMENSION(2) :: glob_sum ! global masked sum 111 132 !! 112 133 INTEGER :: jk 134 #if defined key_z_first 135 INTEGER :: ji, jj 136 REAL(wp) :: ztmask 137 #endif 113 138 !!----------------------------------------------------------------------- 114 139 ! 115 140 glob_sum(:) = 0.e0 141 #if defined key_z_first 142 DO jj = 1, jpj 143 DO ji = 1, jpi 144 ztmask = tmask_i(ji,jj) 145 DO jk = 1, jpk 146 glob_sum(1) = glob_sum(1) + ptab1(ji,jj,jk)*ztmask 147 glob_sum(2) = glob_sum(2) + ptab2(ji,jj,jk)*ztmask 148 END DO 149 END DO 150 END DO 151 #else 116 152 DO jk = 1, jpk 117 153 glob_sum(1) = glob_sum(1) + SUM( ptab1(:,:,jk)*tmask_i(:,:) ) 118 154 glob_sum(2) = glob_sum(2) + SUM( ptab2(:,:,jk)*tmask_i(:,:) ) 119 155 END DO 156 #endif 120 157 IF( lk_mpp ) CALL mpp_sum( glob_sum, 2 ) 121 158 ! … … 161 198 !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine 162 199 !!---------------------------------------------------------------------- 163 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: ptab 164 REAL(wp) :: glob_sum ! global masked sum 200 !FTRANS ptab :I :I :z 201 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab 202 REAL(wp) :: glob_sum ! global masked sum 165 203 !! 166 204 COMPLEX(wp):: ctmp … … 171 209 ztmp = 0.e0 172 210 ctmp = CMPLX( 0.e0, 0.e0, wp ) 211 #if defined key_z_first 212 DO jj = 1, jpj 213 DO ji =1, jpi 214 DO jk = 1, jpk 215 #else 173 216 DO jk = 1, jpk 174 217 DO jj = 1, jpj 175 218 DO ji =1, jpi 219 #endif 176 220 ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) 177 221 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) … … 221 265 !! ** Purpose : perform a sum on two 3D array in calling DDPDD routine 222 266 !!---------------------------------------------------------------------- 223 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: ptab1, ptab2 224 REAL(wp) :: glob_sum ! global masked sum 267 REAL(wp), INTENT(in), DIMENSION(:,:,:) :: ptab1, ptab2 268 !FTRANS ptab1 :I :I :z 269 !FTRANS ptab2 :I :I :z 270 REAL(wp) :: glob_sum ! global masked sum 225 271 !! 226 272 COMPLEX(wp):: ctmp … … 231 277 ztmp = 0.e0 232 278 ctmp = CMPLX( 0.e0, 0.e0, wp ) 279 #if defined key_z_first 280 DO jj = 1, jpj 281 DO ji =1, jpi 282 DO jk = 1, jpk 283 #else 233 284 DO jk = 1, jpk 234 285 DO jj = 1, jpj 235 286 DO ji =1, jpi 287 #endif 236 288 ztmp = ptab1(ji,jj,jk) * tmask_i(ji,jj) 237 289 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r2715 r3187 37 37 !! nemo_alloc : dynamical allocation 38 38 !! nemo_partition : calculate MPP domain decomposition 39 !! factorise : calculate the factors of the no. of MPI processes39 !! sqfact : calculate factors of the no. of MPI processes 40 40 !!---------------------------------------------------------------------- 41 41 USE step_oce ! module used in the ocean time stepping module … … 508 508 !! *** ROUTINE nemo_partition *** 509 509 !! 510 !! ** Purpose : 511 !! 510 !! ** Purpose : Work out a sensible factorisation of the number of 511 !! processors for the x and y dimensions. 512 512 !! ** Method : 513 513 !!---------------------------------------------------------------------- 514 514 INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have 515 515 ! 516 INTEGER, PARAMETER :: nfactmax = 20 517 INTEGER :: nfact ! The no. of factors returned 518 INTEGER :: ierr ! Error flag 519 INTEGER :: ji 520 INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value 521 INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors 522 !!---------------------------------------------------------------------- 523 524 ierr = 0 525 526 CALL factorise( ifact, nfactmax, nfact, num_pes, ierr ) 527 528 IF( nfact <= 1 ) THEN 516 INTEGER :: ifact1, ifact2 ! factors of num_pes, ifact1 <= ifact2 517 !!---------------------------------------------------------------------- 518 519 ! Factorise the number of processors into ifact1*ifact2, such that 520 ! ifact1 and ifact2 are as nearly equal as possible. 521 522 CALL sqfact( num_pes, ifact1, ifact2 ) 523 524 ! Make sure that the smaller dimension of the processor grid 525 ! is given the smaller dimension of the global domain 526 IF( jpiglo <= jpjglo) THEN 527 jpni = ifact1 528 jpnj = ifact2 529 ELSE 530 jpni = ifact2 531 jpnj = ifact1 532 ENDIF 533 534 ! This should never happen 535 IF( (jpni*jpnj) /= num_pes) THEN 536 WRITE (numout, *) 'WARNING: internal error - factorisation of number of PEs failed' 537 ENDIF 538 539 ! This should only happen if num_pes is prime 540 IF( ifact1 <= 1 ) THEN 529 541 WRITE (numout, *) 'WARNING: factorisation of number of PEs failed' 530 WRITE (numout, *) ' : using grid of ',num_pes,' x 1' 531 jpnj = 1 532 jpni = num_pes 533 ELSE 534 ! Search through factors for the pair that are closest in value 535 mindiff = 1000000 536 imin = 1 537 DO ji = 1, nfact-1, 2 538 idiff = ABS( ifact(ji) - ifact(ji+1) ) 539 IF( idiff < mindiff ) THEN 540 mindiff = idiff 541 imin = ji 542 ENDIF 543 END DO 544 jpnj = ifact(imin) 545 jpni = ifact(imin + 1) 542 WRITE (numout, *) ' : using grid of ',jpni,' x ',jpnj 546 543 ENDIF 547 544 ! … … 550 547 END SUBROUTINE nemo_partition 551 548 552 553 SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr ) 554 !!---------------------------------------------------------------------- 555 !! *** ROUTINE factorise *** 556 !! 557 !! ** Purpose : return the prime factors of n. 558 !! knfax factors are returned in array kfax which is of 559 !! maximum dimension kmaxfax. 560 !! ** Method : 561 !!---------------------------------------------------------------------- 562 INTEGER , INTENT(in ) :: kn, kmaxfax 563 INTEGER , INTENT( out) :: kerr, knfax 564 INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax 565 ! 566 INTEGER :: ifac, jl, inu 567 INTEGER, PARAMETER :: ntest = 14 568 INTEGER :: ilfax(ntest) 569 570 ! lfax contains the set of allowed factors. 571 data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, & 572 & 128, 64, 32, 16, 8, 4, 2 / 573 !!---------------------------------------------------------------------- 574 575 ! Clear the error flag and initialise output vars 576 kerr = 0 577 kfax = 1 578 knfax = 0 579 580 ! Find the factors of n. 581 IF( kn == 1 ) GOTO 20 582 583 ! nu holds the unfactorised part of the number. 584 ! knfax holds the number of factors found. 585 ! l points to the allowed factor list. 586 ! ifac holds the current factor. 587 588 inu = kn 589 knfax = 0 590 591 DO jl = ntest, 1, -1 592 ! 593 ifac = ilfax(jl) 594 IF( ifac > inu ) CYCLE 595 596 ! Test whether the factor will divide. 597 598 IF( MOD(inu,ifac) == 0 ) THEN 599 ! 600 knfax = knfax + 1 ! Add the factor to the list 601 IF( knfax > kmaxfax ) THEN 602 kerr = 6 603 write (*,*) 'FACTOR: insufficient space in factor array ', knfax 604 return 605 ENDIF 606 kfax(knfax) = ifac 607 ! Store the other factor that goes with this one 608 knfax = knfax + 1 609 kfax(knfax) = inu / ifac 610 !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax) 611 ENDIF 612 ! 613 END DO 614 615 20 CONTINUE ! Label 20 is the exit point from the factor search loop. 616 ! 617 END SUBROUTINE factorise 549 SUBROUTINE sqfact ( kn, kna, knb ) 550 !!---------------------------------------------------------------------- 551 !! *** ROUTINE sqfact *** 552 !! 553 !! ** Purpose : return factors (kna, knb) of kn, such that 554 !! (1) kna*knb=kn 555 !! (2) kna and knb are as near equal as possible 556 !! (3) kna < knb 557 !! ** Method : Search backwards from the square root of kn, 558 !! until we find an integer that cleanly divides kn 559 !! ** Preconditions : kn must be positive 560 !!---------------------------------------------------------------------- 561 INTEGER, INTENT(in ) :: kn 562 INTEGER, INTENT( out) :: kna, knb 563 564 ! Search backwards from the square root of n. 565 566 fact_loop: DO kna=SQRT(REAL(kn)),1,-1 567 IF ( kn/kna*kna == kn ) THEN 568 EXIT fact_loop 569 ENDIF 570 END DO fact_loop 571 572 IF( kna < 1 ) kna = 1 573 574 ! kna divides kn cleanly. Work out the other factor. 575 knb = kn/kna 576 577 END SUBROUTINE sqfact 618 578 619 579 !!====================================================================== -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/oce.F90
r2715 r3187 47 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gru , grv !: horizontal gradient of rd at bottom u-point 48 48 49 !! * Control permutation of array indices 50 # include "oce_ftrans.h90" 51 49 52 !!---------------------------------------------------------------------- 50 53 !! NEMO/OPA 4.0 , NEMO Consortium (2011) -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/step.F90
r2715 r3187 23 23 !! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface 24 24 !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA 25 !! ! 2011-05 (S. Pickles) dCSE NEMO optimisations - z index first 25 26 !!---------------------------------------------------------------------- 26 27 … … 41 42 42 43 PUBLIC stp ! called by opa.F90 44 45 !! * Control permutation of array indices 46 !! DCSE_NEMO: warning! dom_oce and zdf_oce public variables are made available 47 !! through the use of step_oce 48 # include "dom_oce_ftrans.h90" 49 # include "zdf_oce_ftrans.h90" 43 50 44 51 !! * Substitutions … … 77 84 INTEGER :: jk ! dummy loop indice 78 85 INTEGER :: indic ! error indicator if < 0 86 #if defined key_z_first 87 INTEGER :: ji, jj ! dummy loop indices 88 #endif 79 89 !! --------------------------------------------------------------------- 80 90 … … 126 136 ENDIF 127 137 IF( ln_rnf_mouth ) THEN ! increase diffusivity at rivers mouths 128 DO jk = 2, nkrnf ; avt(:,:,jk) = avt(:,:,jk) + 2.e0 * rn_avt_rnf * rnfmsk(:,:) * tmask(:,:,jk) ; END DO 138 #if defined key_z_first 139 DO ji = 1, jpi 140 DO jj = 1, jpj 141 DO jk = 2, nkrnf 142 avt(ji,jj,jk) = avt(ji,jj,jk) + 2.e0 * rn_avt_rnf * rnfmsk(ji,jj) * tmask(ji,jj,jk) 143 END DO 144 END DO 145 END DO 146 #else 147 DO jk = 2, nkrnf 148 avt(:,:,jk) = avt(:,:,jk) + 2.e0 * rn_avt_rnf * rnfmsk(:,:) * tmask(:,:,jk) 149 END DO 150 #endif 129 151 ENDIF 130 152 IF( ln_zdfevd ) CALL zdf_evd( kstp ) ! enhanced vertical eddy diffusivity … … 235 257 236 258 IF( ln_diahsb ) CALL dia_hsb( kstp ) ! - ML - global conservation diagnostics 237 IF( lk_diaobs ) CALL dia_obs( kstp ) ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 259 IF( lk_diaobs ) CALL dia_obs( kstp ) ! obs-minus-model (assimilation) diagnostics 260 ! ! (call after dynamics update) 238 261 239 262 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/step_oce.F90
r2528 r3187 28 28 USE trabbc ! bottom boundary condition (tra_bbc routine) 29 29 USE trabbl ! bottom boundary layer (tra_bbl routine) 30 USE tradmp ! internal damping (tra_dmp routine) 30 USE tradmp, ONLY : lk_tradmp, tra_dmp_init, tra_dmp 31 ! internal damping (tra_dmp routine) 31 32 USE traadv ! advection scheme control (tra_adv_ctl routine) 32 33 USE traldf ! lateral mixing (tra_ldf routine) -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/stpctl.F90
r2528 r3187 27 27 28 28 PUBLIC stp_ctl ! routine called by step.F90 29 30 !! * Control permutation of array indices 31 # include "oce_ftrans.h90" 32 # include "dom_oce_ftrans.h90" 33 29 34 !!---------------------------------------------------------------------- 30 35 !! NEMO/OPA 3.3 , NEMO Consortium (2010) … … 67 72 ENDIF 68 73 69 IF(lwp) WRITE ( numstp, '(1x, i8)' ) kt !* save the current time step in numstp 70 IF(lwp) REWIND( numstp ) ! -------------------------- 74 !! DCSE_NEMO: commenting out these two lines. Do they mess up the profile? 75 ! IF(lwp) WRITE ( numstp, '(1x, i8)' ) kt !* save the current time step in numstp 76 ! IF(lwp) REWIND( numstp ) ! -------------------------- 71 77 72 78 ! !* Test maximum of velocity (zonal only) … … 74 80 !! zumax = MAXVAL( ABS( un(:,:,:) ) ) ! slower than the following loop on NEC SX5 75 81 zumax = 0.e0 82 #if defined key_z_first 83 DO jj = 1, jpj 84 DO ji = 1, jpi 85 DO jk = 1, jpk 86 #else 76 87 DO jk = 1, jpk 77 88 DO jj = 1, jpj 78 89 DO ji = 1, jpi 90 #endif 79 91 zumax = MAX(zumax,ABS(un(ji,jj,jk))) 80 92 END DO … … 112 124 DO jj = 2, jpjm1 113 125 DO ji = 1, jpi 126 #if defined key_z_first 127 IF( tmask_1(ji,jj) == 1) zsmin = MIN(zsmin,sn(ji,jj,1)) 128 #else 114 129 IF( tmask(ji,jj,1) == 1) zsmin = MIN(zsmin,sn(ji,jj,1)) 130 #endif 115 131 END DO 116 132 END DO … … 121 137 IF( zsmin < 0.) THEN 122 138 IF (lk_mpp) THEN 139 #if defined key_z_first 140 CALL mpp_minloc ( sn(:,:,1),tmask_1(:,:), zsmin, ii,ij ) 141 #else 123 142 CALL mpp_minloc ( sn(:,:,1),tmask(:,:,1), zsmin, ii,ij ) 143 #endif 124 144 ELSE 145 #if defined key_z_first 146 ilocs = MINLOC( sn(:,:,1), mask = tmask_1(:,:) == 1.e0 ) 147 #else 125 148 ilocs = MINLOC( sn(:,:,1), mask = tmask(:,:,1) == 1.e0 ) 149 #endif 126 150 ii = ilocs(1) + nimpp - 1 127 151 ij = ilocs(2) + njmpp - 1 -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/trc_oce.F90
r2715 r3187 49 49 LOGICAL, PUBLIC, PARAMETER :: lk_offline = .FALSE. !: offline flag 50 50 #endif 51 52 !! * Array index permutations 53 # include "dom_oce_ftrans.h90" 54 # include "trc_oce_ftrans.h90" 51 55 52 56 !! * Substitutions … … 249 253 !!---------------------------------------------------------------------- 250 254 ! 251 ! It is not necessary to compute anything bel low the following depth255 ! It is not necessary to compute anything below the following depth 252 256 zhext = prldex * ( LOG(10._wp) * zprec + LOG(pqsr_frc) ) 253 257 ! 254 258 ! Level of light extinction 259 !FTRANS fsdepw :I :I :z 260 !FTRANS tmask :I :I :z 255 261 pjl = jpkm1 256 262 DO jk = jpkm1, 1, -1 -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/vectopt_loop_substitute.h90
r2528 r3187 2 2 !! *** vectopt_loop_substitute *** 3 3 !!---------------------------------------------------------------------- 4 !! ** purpose : substitute the inner loop starting and inding indices4 !! ** purpose : substitute the inner loop starting and ending indices 5 5 !! to allow unrolling of do-loop using CPP macro. 6 6 !!---------------------------------------------------------------------- -
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90
r2715 r3187 98 98 CHARACTER(LEN=*), PARAMETER :: cform_err2 = "(/,' ===>>> : E R R O R', /,' ===========',/)" !: 99 99 CHARACTER(LEN=*), PARAMETER :: cform_war2 = "(/,' ===>>> : W A R N I N G', /,' ===============',/)" !: 100 101 !! * Array index permutations 102 # include "wrk_nemo_ftrans.h90" 100 103 101 104 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.