Changeset 3294 for trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
- Timestamp:
- 2012-01-28T17:44:18+01:00 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r2715 r3294 29 29 USE lib_mpp ! MPP library 30 30 USE lbclnk ! lateral boundary condition - processor exchanges 31 USE timing ! preformance summary 32 USE wrk_nemo ! working arrays 31 33 32 34 IMPLICIT NONE … … 95 97 !!---------------------------------------------------------------------- 96 98 INTEGER :: dia_ptr_alloc ! return value 97 INTEGER, DIMENSION( 5) :: ierr99 INTEGER, DIMENSION(6) :: ierr 98 100 !!---------------------------------------------------------------------- 99 101 ierr(:) = 0 … … 121 123 & ndex_h_ind_30(jpj), ndex_h_ipc_30(jpj), Stat=ierr(5) ) 122 124 ! 125 ALLOCATE( btm30(jpi,jpj) , STAT=ierr(6) ) 126 ! 123 127 dia_ptr_alloc = MAXVAL( ierr ) 124 128 IF(lk_mpp) CALL mpp_sum( dia_ptr_alloc ) … … 209 213 !! ** Action : - p_fval: i-mean poleward flux of pva 210 214 !!---------------------------------------------------------------------- 211 #if defined key_mpp_mpi212 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released213 USE wrk_nemo, ONLY: zwork => wrk_1d_1214 #endif215 215 !! 216 216 IMPLICIT none … … 225 225 INTEGER :: ijpjjpk 226 226 #endif 227 #if defined key_mpp_mpi 228 REAL(wp), POINTER, DIMENSION(:) :: zwork ! mask flux array at V-point 229 #endif 227 230 !!-------------------------------------------------------------------- 228 231 ! 229 232 #if defined key_mpp_mpi 230 IF( wrk_in_use(1, 1) ) THEN 231 CALL ctl_stop('ptr_vjk: ERROR - requested workspace array is unavailable') ; RETURN 232 END IF 233 ijpjjpk = jpj*jpk 234 CALL wrk_alloc( jpj*jpk, zwork ) 233 235 #endif 234 236 … … 257 259 ! 258 260 #if defined key_mpp_mpi 259 ijpjjpk = jpj*jpk260 261 ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk 261 262 zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) … … 265 266 ! 266 267 #if defined key_mpp_mpi 267 IF( wrk_not_released(1, 1) ) CALL ctl_stop('ptr_vjk: ERROR - failed to release workspace array')268 CALL wrk_dealloc( jpj*jpk, zwork ) 268 269 #endif 269 270 ! … … 281 282 !! ** Action : - p_fval: i-sum of e1t*e3t*pta 282 283 !!---------------------------------------------------------------------- 283 #if defined key_mpp_mpi284 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released285 USE wrk_nemo, ONLY: zwork => wrk_1d_1286 #endif287 284 !! 288 285 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! tracer flux array at T-point … … 296 293 INTEGER :: ijpjjpk 297 294 #endif 295 #if defined key_mpp_mpi 296 REAL(wp), POINTER, DIMENSION(:) :: zwork ! mask flux array at V-point 297 #endif 298 298 !!-------------------------------------------------------------------- 299 299 ! 300 300 #if defined key_mpp_mpi 301 IF( wrk_in_use(1, 1) ) THEN 302 CALL ctl_stop('ptr_tjk: requested workspace array unavailable') ; RETURN 303 ENDIF 301 ijpjjpk = jpj*jpk 302 CALL wrk_alloc( jpj*jpk, zwork ) 304 303 #endif 305 304 … … 315 314 END DO 316 315 #if defined key_mpp_mpi 317 ijpjjpk = jpj*jpk318 316 ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk 319 317 zwork(1:ijpjjpk)= RESHAPE( p_fval, ish ) … … 323 321 ! 324 322 #if defined key_mpp_mpi 325 IF( wrk_not_released(1, 1) ) CALL ctl_stop('ptr_tjk: failed to release workspace array')323 CALL wrk_dealloc( jpj*jpk, zwork ) 326 324 #endif 327 325 ! … … 343 341 !!---------------------------------------------------------------------- 344 342 ! 343 IF( nn_timing == 1 ) CALL timing_start('dia_ptr') 344 ! 345 345 IF( kt == nit000 .OR. MOD( kt, nn_fptr ) == 0 ) THEN 346 346 ! … … 349 349 IF( ln_diaznl ) THEN ! i-mean temperature and salinity 350 350 DO jn = 1, nptr 351 tn_jk(:,:,jn) = ptr_tjk( t n(:,:,:), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)351 tn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 352 352 END DO 353 353 ENDIF … … 368 368 ! 369 369 ! ! Transports 370 ! ! local heat & salt transports at T-points ( t n*mj[vn+v_eiv] )370 ! ! local heat & salt transports at T-points ( tsn*mj[vn+v_eiv] ) 371 371 vt(:,:,jpk) = 0._wp ; vs(:,:,jpk) = 0._wp 372 372 DO jk= 1, jpkm1 … … 378 378 zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp 379 379 #endif 380 vt(:,jj,jk) = zv * t n(:,jj,jk)381 vs(:,jj,jk) = zv * sn(:,jj,jk)380 vt(:,jj,jk) = zv * tsn(:,jj,jk,jp_tem) 381 vs(:,jj,jk) = zv * tsn(:,jj,jk,jp_sal) 382 382 END DO 383 383 END DO … … 430 430 ENDIF 431 431 ! 432 IF( kt == nitend ) CALL histclo( numptr ) ! Close the file 432 #if defined key_mpp_mpi 433 IF( kt == nitend .AND. l_znl_root ) CALL histclo( numptr ) ! Close the file 434 #else 435 IF( kt == nitend ) CALL histclo( numptr ) ! Close the file 436 #endif 437 ! 438 IF( nn_timing == 1 ) CALL timing_stop('dia_ptr') 433 439 ! 434 440 END SUBROUTINE dia_ptr … … 449 455 NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri 450 456 !!---------------------------------------------------------------------- 451 452 ! ! allocate dia_ptr arrays 453 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'lim_sbc_init : unable to allocate arrays' ) 457 IF( nn_timing == 1 ) CALL timing_start('dia_ptr_init') 454 458 455 459 REWIND( numnam ) ! Read Namelist namptr : poleward transport parameters … … 468 472 WRITE(numout,*) ' Frequency of outputs nn_fwri = ', nn_fwri 469 473 ENDIF 470 471 IF( ln_subbas ) THEN ; nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific472 ELSE ; nptr = 1 ! Global only473 ENDIF474 475 rc_pwatt = rc_pwatt * rau0 * rcp ! conversion from K.s-1 to PetaWatt476 477 IF( .NOT. ln_diaptr ) THEN ! diaptr not used478 RETURN479 ENDIF480 474 481 IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum 482 483 IF( ln_subbas ) THEN ! load sub-basin mask 484 CALL iom_open( 'subbasins', inum ) 485 CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 486 CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 487 CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin 488 CALL iom_close( inum ) 489 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 490 WHERE( gphit(:,:) < -30._wp) ; btm30(:,:) = 0._wp ! mask out Southern Ocean 491 ELSE WHERE ; btm30(:,:) = tmask(:,:,1) 492 END WHERE 493 ENDIF 494 btmsk(:,:,1) = tmask_i(:,:) ! global ocean 475 IF( ln_diaptr) THEN 495 476 496 DO jn = 1, nptr 497 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 498 END DO 477 IF( ln_subbas ) THEN ; nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific 478 ELSE ; nptr = 1 ! Global only 479 ENDIF 480 481 ! ! allocate dia_ptr arrays 482 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) 483 484 rc_pwatt = rc_pwatt * rau0 * rcp ! conversion from K.s-1 to PetaWatt 485 486 IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum 487 488 IF( ln_subbas ) THEN ! load sub-basin mask 489 CALL iom_open( 'subbasins', inum ) 490 CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 491 CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 492 CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin 493 CALL iom_close( inum ) 494 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 495 WHERE( gphit(:,:) < -30._wp) ; btm30(:,:) = 0._wp ! mask out Southern Ocean 496 ELSE WHERE ; btm30(:,:) = tmask(:,:,1) 497 END WHERE 498 ENDIF 499 btmsk(:,:,1) = tmask_i(:,:) ! global ocean 499 500 500 IF( lk_vvl ) CALL ctl_stop( 'diaptr: error in vvl case as constant i-mean surface is used' ) 501 502 ! ! i-sum of e1v*e3v surface and its inverse 503 DO jn = 1, nptr 504 sjk(:,:,jn) = ptr_tjk( tmask(:,:,:), btmsk(:,:,jn) ) 505 r1_sjk(:,:,jn) = 0._wp 506 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 507 END DO 501 DO jn = 1, nptr 502 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 503 END DO 504 505 IF( lk_vvl ) CALL ctl_stop( 'diaptr: error in vvl case as constant i-mean surface is used' ) 506 507 ! ! i-sum of e1v*e3v surface and its inverse 508 DO jn = 1, nptr 509 sjk(:,:,jn) = ptr_tjk( tmask(:,:,:), btmsk(:,:,jn) ) 510 r1_sjk(:,:,jn) = 0._wp 511 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 512 END DO 513 514 ! Initialise arrays to zero because diatpr is called before they are first calculated 515 ! Note that this means diagnostics will not be exactly correct when model run is restarted. 516 htr_adv(:) = 0._wp ; str_adv(:) = 0._wp ; htr_ldf(:) = 0._wp ; str_ldf(:) = 0._wp 508 517 509 518 #if defined key_mpp_mpi 510 iglo (1) = jpjglo ! MPP case using MPI ('key_mpp_mpi')511 iloc (1) = nlcj512 iabsf(1) = njmppt(narea)513 iabsl(:) = iabsf(:) + iloc(:) - 1514 ihals(1) = nldj - 1515 ihale(1) = nlcj - nlej516 idid (1) = 2517 CALL flio_dom_set( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr )519 iglo (1) = jpjglo ! MPP case using MPI ('key_mpp_mpi') 520 iloc (1) = nlcj 521 iabsf(1) = njmppt(narea) 522 iabsl(:) = iabsf(:) + iloc(:) - 1 523 ihals(1) = nldj - 1 524 ihale(1) = nlcj - nlej 525 idid (1) = 2 526 CALL flio_dom_set( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr ) 518 527 #else 519 nidom_ptr = FLIO_DOM_NONE 520 #endif 528 nidom_ptr = FLIO_DOM_NONE 529 #endif 530 ENDIF 531 ! 532 IF( nn_timing == 1 ) CALL timing_stop('dia_ptr_init') 521 533 ! 522 534 END SUBROUTINE dia_ptr_init … … 531 543 !! ** Method : NetCDF file 532 544 !!---------------------------------------------------------------------- 533 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released534 USE wrk_nemo, ONLY: zphi => wrk_1d_1, zfoo => wrk_1d_2 ! 1D workspace535 USE wrk_nemo, ONLY: z_1 => wrk_2d_1 ! 2D -536 545 !! 537 546 INTEGER, INTENT(in) :: kt ! ocean time-step index … … 548 557 #endif 549 558 REAL(wp) :: zsto, zout, zdt, zjulian ! temporary scalars 550 !!---------------------------------------------------------------------- 551 552 IF( wrk_in_use(1, 1,2) .OR. wrk_in_use(2, 1) ) THEN 553 CALL ctl_stop('dia_ptr_wri: requested workspace arrays unavailable') ; RETURN 554 ENDIF 559 !! 560 REAL(wp), POINTER, DIMENSION(:) :: zphi, zfoo ! 1D workspace 561 REAL(wp), POINTER, DIMENSION(:,:) :: z_1 ! 2D workspace 562 !!-------------------------------------------------------------------- 563 ! 564 CALL wrk_alloc( jpi , zphi , zfoo ) 565 CALL wrk_alloc( jpi , jpk, z_1 ) 555 566 556 567 ! define time axis … … 866 877 ENDIF 867 878 ! 868 IF( wrk_not_released(1, 1,2) .OR. &869 wrk_not_released(2, 1) ) CALL ctl_stop('dia_ptr_wri: failed to release workspace arrays')879 CALL wrk_dealloc( jpi , zphi , zfoo ) 880 CALL wrk_dealloc( jpi , jpk, z_1 ) 870 881 ! 871 882 END SUBROUTINE dia_ptr_wri
Note: See TracChangeset
for help on using the changeset viewer.