New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 3294 for trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 – NEMO

Ignore:
Timestamp:
2012-01-28T17:44:18+01:00 (12 years ago)
Author:
rblod
Message:

Merge of 3.4beta into the trunk

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90

    r2715 r3294  
    2929   USE lib_mpp          ! MPP library 
    3030   USE lbclnk           ! lateral boundary condition - processor exchanges 
     31   USE timing           ! preformance summary 
     32   USE wrk_nemo         ! working arrays 
    3133 
    3234   IMPLICIT NONE 
     
    9597      !!---------------------------------------------------------------------- 
    9698      INTEGER               ::   dia_ptr_alloc   ! return value 
    97       INTEGER, DIMENSION(5) ::   ierr 
     99      INTEGER, DIMENSION(6) ::   ierr 
    98100      !!---------------------------------------------------------------------- 
    99101      ierr(:) = 0 
     
    121123         &     ndex_h_ind_30(jpj),   ndex_h_ipc_30(jpj), Stat=ierr(5) ) 
    122124         ! 
     125     ALLOCATE( btm30(jpi,jpj) , STAT=ierr(6)  ) 
     126         ! 
    123127      dia_ptr_alloc = MAXVAL( ierr ) 
    124128      IF(lk_mpp)   CALL mpp_sum( dia_ptr_alloc ) 
     
    209213      !! ** Action  : - p_fval: i-mean poleward flux of pva 
    210214      !!---------------------------------------------------------------------- 
    211 #if defined key_mpp_mpi 
    212       USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    213       USE wrk_nemo, ONLY:   zwork => wrk_1d_1 
    214 #endif 
    215215      !! 
    216216      IMPLICIT none 
     
    225225      INTEGER               ::   ijpjjpk 
    226226#endif 
     227#if defined key_mpp_mpi 
     228      REAL(wp), POINTER, DIMENSION(:) ::   zwork    ! mask flux array at V-point 
     229#endif 
    227230      !!-------------------------------------------------------------------- 
    228231      ! 
    229232#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 ) 
    233235#endif 
    234236 
     
    257259      ! 
    258260#if defined key_mpp_mpi 
    259       ijpjjpk = jpj*jpk 
    260261      ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk 
    261262      zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 
     
    265266      ! 
    266267#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 ) 
    268269#endif 
    269270      ! 
     
    281282      !! ** Action  : - p_fval: i-sum of e1t*e3t*pta 
    282283      !!---------------------------------------------------------------------- 
    283 #if defined key_mpp_mpi 
    284       USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    285       USE wrk_nemo, ONLY:   zwork => wrk_1d_1 
    286 #endif 
    287284      !! 
    288285      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! tracer flux array at T-point 
     
    296293      INTEGER               ::   ijpjjpk 
    297294#endif 
     295#if defined key_mpp_mpi 
     296      REAL(wp), POINTER, DIMENSION(:) ::   zwork    ! mask flux array at V-point 
     297#endif 
    298298      !!--------------------------------------------------------------------  
    299299      ! 
    300300#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 ) 
    304303#endif 
    305304 
     
    315314      END DO 
    316315#if defined key_mpp_mpi 
    317       ijpjjpk = jpj*jpk 
    318316      ish(1) = jpj*jpk   ;   ish2(1) = jpj   ;   ish2(2) = jpk 
    319317      zwork(1:ijpjjpk)= RESHAPE( p_fval, ish ) 
     
    323321      ! 
    324322#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 ) 
    326324#endif 
    327325      !     
     
    343341      !!---------------------------------------------------------------------- 
    344342      ! 
     343      IF( nn_timing == 1 )   CALL timing_start('dia_ptr') 
     344      ! 
    345345      IF( kt == nit000 .OR. MOD( kt, nn_fptr ) == 0 )   THEN 
    346346         ! 
     
    349349            IF( ln_diaznl ) THEN               ! i-mean temperature and salinity 
    350350               DO jn = 1, nptr 
    351                   tn_jk(:,:,jn) = ptr_tjk( tn(:,:,:), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 
     351                  tn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 
    352352               END DO 
    353353            ENDIF 
     
    368368            ! 
    369369            !                          ! Transports 
    370             !                                ! local heat & salt transports at T-points  ( tn*mj[vn+v_eiv] ) 
     370            !                                ! local heat & salt transports at T-points  ( tsn*mj[vn+v_eiv] ) 
    371371            vt(:,:,jpk) = 0._wp   ;   vs(:,:,jpk) = 0._wp 
    372372            DO jk= 1, jpkm1 
     
    378378                     zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp 
    379379#endif  
    380                      vt(:,jj,jk) = zv * tn(:,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) 
    382382                  END DO 
    383383               END DO 
     
    430430      ENDIF 
    431431      ! 
    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') 
    433439      ! 
    434440   END SUBROUTINE dia_ptr 
     
    449455      NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri 
    450456      !!---------------------------------------------------------------------- 
    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') 
    454458 
    455459      REWIND( numnam )                 ! Read Namelist namptr : poleward transport parameters 
     
    468472         WRITE(numout,*) '      Frequency of outputs                               nn_fwri    = ', nn_fwri 
    469473      ENDIF 
    470  
    471       IF( ln_subbas ) THEN   ;   nptr = 5       ! Global, Atlantic, Pacific, Indian, Indo-Pacific 
    472       ELSE                   ;   nptr = 1       ! Global only 
    473       ENDIF 
    474  
    475       rc_pwatt = rc_pwatt * rau0 * rcp          ! conversion from K.s-1 to PetaWatt 
    476  
    477       IF( .NOT. ln_diaptr ) THEN       ! diaptr not used 
    478         RETURN 
    479       ENDIF 
    480474       
    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   
    495476       
    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 
    499500       
    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 
    508517 
    509518#if defined key_mpp_mpi  
    510       iglo (1) = jpjglo                   ! MPP case using MPI  ('key_mpp_mpi') 
    511       iloc (1) = nlcj 
    512       iabsf(1) = njmppt(narea) 
    513       iabsl(:) = iabsf(:) + iloc(:) - 1 
    514       ihals(1) = nldj - 1 
    515       ihale(1) = nlcj - nlej 
    516       idid (1) = 2 
    517       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 ) 
    518527#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') 
    521533      !  
    522534   END SUBROUTINE dia_ptr_init 
     
    531543      !! ** Method  :   NetCDF file 
    532544      !!---------------------------------------------------------------------- 
    533       USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    534       USE wrk_nemo, ONLY:   zphi => wrk_1d_1, zfoo => wrk_1d_2    ! 1D workspace 
    535       USE wrk_nemo, ONLY:   z_1  => wrk_2d_1                      ! 2D      - 
    536545      !! 
    537546      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     
    548557#endif 
    549558      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 ) 
    555566 
    556567      ! define time axis 
     
    866877      ENDIF 
    867878      ! 
    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 ) 
    870881      ! 
    871882  END SUBROUTINE dia_ptr_wri 
Note: See TracChangeset for help on using the changeset viewer.