source: branches/UKMO/dev_r5518_flux_correction/NEMOGCM/NEMO/OPA_SRC/SBC/sbchfp.F90

MODULE sbchfp
   !!======================================================================
   !!                       ***  MODULE  sbchfp ***
   !! Surface module :  apply perturbation term to surface heat flux (qns)
   !!======================================================================
   !! History :  3.6  !  2017-12  (D. Storkey)  Original code
   !!----------------------------------------------------------------------

   !!----------------------------------------------------------------------
   !!   sbc_hfp       : add perturbation term to qns
   !!   sbc_hfp_init  : initialisation of heat flux perturbation field
   !!----------------------------------------------------------------------
   USE oce            ! ocean dynamics and tracers
   USE dom_oce        ! ocean space and time domain
   USE sbc_oce        ! surface boundary condition
   USE phycst         ! physical constants
   !
   USE fldread        ! read input fields
   USE iom            ! I/O manager
   USE in_out_manager ! I/O manager
   USE lib_mpp        ! distribued memory computing library
   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
   USE timing         ! Timing
   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)  
   USE wrk_nemo       ! work arrays

   IMPLICIT NONE
   PRIVATE

   PUBLIC   sbc_hfp        ! routine called in sbcmod
   PUBLIC   sbc_hfp_init   ! routine called in sbcmod

!!$   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   erp   !: evaporation damping   [kg/m2/s]
!!$   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qrp   !: heat flux damping        [w/m2]

   !                                   !!* Namelist namsbc_hfp *
   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_hfp   ! structure of input heat flux perturbation (file informations, fields read)

   !! * Substitutions
#  include "domzgr_substitute.h90"
   !!----------------------------------------------------------------------
   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
   !! $Id$
   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
   !!----------------------------------------------------------------------
CONTAINS

   SUBROUTINE sbc_hfp( kt )
      !!---------------------------------------------------------------------
      !!                     ***  ROUTINE sbc_hfp  ***
      !!
      !! ** Purpose :   Add perturbation term to qns
      !!
      !! ** Method  : 
      !!              
      !!---------------------------------------------------------------------
      INTEGER, INTENT(in   ) ::   kt   ! ocean time step
      !!
      INTEGER  ::   ierror   ! return error code
      REAL(wp), POINTER, DIMENSION(:,:) ::   zqcorr ! 2D workspace
      !!----------------------------------------------------------------------
      !
      IF( nn_timing == 1 )  CALL timing_start('sbc_hfp')
      !
      CALL wrk_alloc( jpi, jpj, zqcorr )
      !
      CALL fld_read( kt, nn_fsbc, sf_hfp )   ! Read in heat flux perturbation and provide it at kt
      !
      !                                         ! ========================= !
      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN      !   Add perturbation term   !
         !                                      ! ========================= !
         !
         zqcorr(:,:) = sf_hfp(1)%fnow(:,:,1)
         WHERE( fr_i(:,:) > 0 .and. fr_i(:,:) < 0.5 ) 
            zqcorr(:,:) = zqcorr(:,:) * ( 1.0 - 2.0 * fr_i(:,:) )
         ENDWHERE
         WHERE( fr_i(:,:) >= 0.5 ) 
            zqcorr(:,:) = 0.0
         ENDWHERE
         qns(:,:) = ( qns(:,:) - zqcorr(:,:) ) * tmask(:,:,1)
         !
         CALL iom_put( "qcorr_oce",   zqcorr )       ! perturbation to downward heat flux over the ocean
      ENDIF         
      !
      IF( nn_timing == 1 )  CALL timing_stop('sbc_hfp')
      !
   END SUBROUTINE sbc_hfp

 
   SUBROUTINE sbc_hfp_init
      !!---------------------------------------------------------------------
      !!                  ***  ROUTINE sbc_hfp_init  ***
      !!
      !! ** Purpose :   initialisation of heat flux perturbation
      !!
      !! ** Method  : - Read namelist namsbc_hfp
      !!              - Initialise heat flux perturbation field (to be read from file)
      !!---------------------------------------------------------------------
      INTEGER  ::   ierror   ! return error code
      !!
      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files
      TYPE(FLD_N) ::   sn_hfp            ! informations about the fields to be read
      NAMELIST/namsbc_hfp/ cn_dir, sn_hfp
      INTEGER     ::  ios
      !!----------------------------------------------------------------------
      !
 
      REWIND( numnam_ref )              ! Namelist namsbc_hfp in reference namelist : 
      READ  ( numnam_ref, namsbc_hfp, IOSTAT = ios, ERR = 901)
901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_hfp in reference namelist', lwp )

      REWIND( numnam_cfg )              ! Namelist namsbc_hfp in configuration namelist :
      READ  ( numnam_cfg, namsbc_hfp, IOSTAT = ios, ERR = 902 )
902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_hfp in configuration namelist', lwp )
      IF(lwm) WRITE ( numond, namsbc_hfp )

      !* set sf_hfp structure & allocate arrays
      !
      ALLOCATE( sf_hfp(1), STAT=ierror )
      IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_hfp: unable to allocate sf_hfp structure' )
      ALLOCATE( sf_hfp(1)%fnow(jpi,jpj,1), STAT=ierror )
      IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_hfp: unable to allocate sf_sst now array' )
      !
      ! fill sf_hfp with sn_hfp and control print
      CALL fld_fill( sf_hfp, (/ sn_hfp /), cn_dir, 'sbc_hfp', 'heat flux perturbation', 'namsbc_hfp' )
      IF( sf_hfp(1)%ln_tint )   ALLOCATE( sf_hfp(1)%fdta(jpi,jpj,1,2), STAT=ierror )
      IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_hfp: unable to allocate sf_hfp data array' )
      !
      !
   END SUBROUTINE sbc_hfp_init
      
   !!======================================================================
END MODULE sbchfp