MODULE sbcclo !!====================================================================== !! *** MODULE sbcclo *** !! Ocean forcing: closea sea correction !!===================================================================== !! History : 4.1 ! 2019-09 (P. Mathiot) original !! NEMO !!---------------------------------------------------------------------- ! !!---------------------------------------------------------------------- !! sbc_clo : update emp and qns over target area and source area !! sbc_clo_init : initialise all variable needed for closed sea correction !! !! alloc_cssurf : allocate closed sea surface array !! alloc_csgrp : allocate closed sea group array !! get_cssrcsurf : compute source surface area !! get_cstrgsurf : compute target surface area !! prt_csctl : closed sea control print !! sbc_csupdate : compute net fw from closed sea !!---------------------------------------------------------------------- ! USE oce ! dynamics and tracers USE dom_oce ! ocean space and time domain USE closea ! closed sea USE phycst ! physical constants USE sbc_oce ! ocean surface boundary conditions USE iom ! I/O routines ! USE in_out_manager ! I/O manager USE lib_fortran, ONLY: glob_sum USE lib_mpp ! MPP library ! IMPLICIT NONE ! PRIVATE alloc_cssurf PRIVATE alloc_csgrp PRIVATE get_cssrcsurf PRIVATE get_cstrgsurf PRIVATE prt_csctl PRIVATE sbc_csupdate ! PUBLIC sbc_clo PUBLIC sbc_clo_init ! REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcg, rsurftrgg !: closed sea target glo surface areas REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcr, rsurftrgr !: closed sea target rnf surface areas REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrce, rsurftrge !: closed sea target emp surface areas ! INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: mcsgrpg, mcsgrpr, mcsgrpe !: closed sea group for glo, rnf and emp ! CONTAINS ! !!---------------------------------------------------------------------- !! Public subroutines !!---------------------------------------------------------------------- ! SUBROUTINE sbc_clo_init !!--------------------------------------------------------------------- !! *** ROUTINE sbc_clo_init *** !! !! ** Purpose : Initialisation of the net fw closed sea correction !! !! ** Method : - compute source surface area for each closed sea !! - defined the group of each closed sea !! (needed to manage multiple closed sea and one target area like great lakes / St Laurent outlet) !! - compute target surface area and corresponding group for each closed sea !!---------------------------------------------------------------------- ! ! 0. Allocate cs variables (surf) CALL alloc_cssurf( ncsg, rsurfsrcg, rsurftrgg ) CALL alloc_cssurf( ncsr, rsurfsrcr, rsurftrgr ) CALL alloc_cssurf( ncse, rsurfsrce, rsurftrge ) ! ! 1. compute source surface area CALL get_cssrcsurf( ncsg, mask_csglo, rsurfsrcg ) CALL get_cssrcsurf( ncsr, mask_csrnf, rsurfsrcr ) CALL get_cssrcsurf( ncse, mask_csemp, rsurfsrce ) ! ! 2. Allocate cs group variables (mcsgrp) CALL alloc_csgrp( ncsg, mcsgrpg ) CALL alloc_csgrp( ncsr, mcsgrpr ) CALL alloc_csgrp( ncse, mcsgrpe ) ! ! 3. compute target surface area and group number (mcsgrp) for all cs and cases ! glo could be simpler but for lisibility, all treated the same way ! It is only done once, so not a big deal CALL get_cstrgsurf( ncsg, mask_csglo, mask_csgrpglo, rsurftrgg, mcsgrpg ) CALL get_cstrgsurf( ncsr, mask_csrnf, mask_csgrprnf, rsurftrgr, mcsgrpr ) CALL get_cstrgsurf( ncse, mask_csemp, mask_csgrpemp, rsurftrge, mcsgrpe ) ! ! 4. print out in ocean.ouput CALL prt_csctl( ncsg, rsurfsrcg, rsurftrgg, mcsgrpg, 'glo' ) CALL prt_csctl( ncsr, rsurfsrcr, rsurftrgr, mcsgrpr, 'rnf' ) CALL prt_csctl( ncse, rsurfsrce, rsurftrge, mcsgrpe, 'emp' ) END SUBROUTINE sbc_clo_init SUBROUTINE sbc_clo( kt ) ! to be move in SBC in a file sbcclo ??? !!--------------------------------------------------------------------- !! *** ROUTINE sbc_clo *** !! !! ** Purpose : Special handling of closed seas !! !! ** Method : Water flux is forced to zero over closed sea !! Excess is shared between remaining ocean, or !! put as run-off in open ocean. !! !! ** Action : - compute surface freshwater fluxes and associated heat content flux at kt !! - output closed sea contribution to fw and heat budget !! - update emp and qns !!---------------------------------------------------------------------- INTEGER , INTENT(in ) :: kt ! ocean model time step ! REAL(wp), DIMENSION(jpi,jpj) :: zwcs, zqcs ! water flux and heat flux correction due to closed seas !!---------------------------------------------------------------------- ! ! 0. initialisation zwcs(:,:) = 0._wp ; zqcs(:,:) = 0._wp ! ! 1. update emp and qns CALL sbc_csupdate( ncsg, mcsgrpg, mask_csglo, mask_csgrpglo, rsurfsrcg, rsurftrgg, 'glo', mask_opnsea, rsurftrgg, zwcs, zqcs ) CALL sbc_csupdate( ncsr, mcsgrpr, mask_csrnf, mask_csgrprnf, rsurfsrcr, rsurftrgr, 'rnf', mask_opnsea, rsurftrgg, zwcs, zqcs ) CALL sbc_csupdate( ncse, mcsgrpe, mask_csemp, mask_csgrpemp, rsurfsrce, rsurftrge, 'emp', mask_opnsea, rsurftrgg, zwcs, zqcs ) ! ! 2. ouput closed sea contributions CALL iom_put('wclosea',zwcs) CALL iom_put('qclosea',zqcs) ! ! 3. update emp and qns emp(:,:) = emp(:,:) + zwcs(:,:) qns(:,:) = qns(:,:) + zqcs(:,:) ! END SUBROUTINE sbc_clo ! !!---------------------------------------------------------------------- !! Private subroutines !!---------------------------------------------------------------------- ! SUBROUTINE get_cssrcsurf(kncs, kmaskcs, psurfsrc) !!----------------------------------------------------------------------- !! *** routine get_cssrcsurf *** !! !! ** Purpose : compute closed sea (source) surface area !!---------------------------------------------------------------------- ! subroutine parameters INTEGER, INTENT(in ) :: kncs ! closed sea number INTEGER, DIMENSION(:,:), INTENT(in ) :: kmaskcs ! closed sea mask REAL(wp), DIMENSION(:) , INTENT(inout) :: psurfsrc ! source surface area ! local variables INTEGER :: jcs ! loop index INTEGER, DIMENSION(jpi,jpj) :: imsksrc ! source mask !!---------------------------------------------------------------------- ! DO jcs = 1,kncs ! loop over closed seas ! ! 0. build river mouth mask for this lake WHERE ( kmaskcs == jcs ) imsksrc = 1 ELSE WHERE imsksrc = 0 END WHERE ! ! 1. compute target area psurfsrc(jcs) = glob_sum('closea', e1e2t(:,:) * imsksrc(:,:) ) ! END DO ! jcs END SUBROUTINE SUBROUTINE get_cstrgsurf(kncs, kmaskcs, kmaskcsgrp, psurftrg, kcsgrp ) !!----------------------------------------------------------------------- !! *** routine get_cstrgsurf *** !! !! ** Purpose : compute closed sea (target) surface area !!---------------------------------------------------------------------- ! subroutine parameters INTEGER, INTENT(in ) :: kncs ! closed sea number INTEGER, DIMENSION(:) , INTENT(inout) :: kcsgrp ! closed sea group number INTEGER, DIMENSION(:,:), INTENT(in ) :: kmaskcs, kmaskcsgrp ! closed sea and group mask REAL(wp), DIMENSION(:) , INTENT(inout) :: psurftrg ! target surface area ! local variables INTEGER :: jcs, jtmp ! tmp INTEGER, DIMENSION(jpi,jpj) :: imskgrp, imsksrc, imsktrg ! tmp group, source and target mask !!---------------------------------------------------------------------- ! DO jcs = 1,kncs ! loop over closed seas ! !! 0. find group number for cs number jcs imskgrp = kmaskcsgrp imsksrc = kmaskcs ! ! set cs value where cs is imsktrg = HUGE(1) WHERE ( imsksrc == jcs ) imsktrg = jcs ! ! zmsk = HUGE outside the cs number jcs ! ktmp = jcs - group number ! jgrp = group corresponding to the cs jcs imsktrg = imsktrg - imskgrp jtmp = MINVAL(imsktrg) ; CALL mpp_min('closea',jtmp) kcsgrp(jcs) = jcs - jtmp ! !! 1. build river mouth mask for this lake WHERE ( imskgrp * mask_opnsea == kcsgrp(jcs) ) imsktrg = 1 ELSE WHERE imsktrg = 0 END WHERE ! !! 2. compute target area psurftrg(jcs) = glob_sum('closea', e1e2t(:,:) * imsktrg(:,:) ) ! END DO ! jcs END SUBROUTINE SUBROUTINE prt_csctl(kncs, psurfsrc, psurftrg, kcsgrp, cdcstype) !!----------------------------------------------------------------------- !! *** routine prt_csctl *** !! !! ** Purpose : output information about each closed sea (src id, trg id, src area and trg area) !!---------------------------------------------------------------------- ! subroutine parameters INTEGER, INTENT(in ) :: kncs ! closed sea number INTEGER, DIMENSION(:), INTENT(in ) :: kcsgrp ! closed sea group number ! REAL(wp), DIMENSION(:), INTENT(in ) :: psurfsrc, psurftrg ! source and target surface area ! CHARACTER(256), INTENT(in ) :: cdcstype ! closed sea scheme used for redistribution ! ! local variable INTEGER :: jcs !!---------------------------------------------------------------------- ! IF ( lwp .AND. kncs > 0 ) THEN WRITE(numout,*)'' ! WRITE(numout,*)'Closed sea target ',TRIM(cdcstype),' : ' ! DO jcs = 1,kncs WRITE(numout,FMT='(3a,i3,a,i3)') ' ',TRIM(cdcstype),' closed sea id is ',jcs,' and trg id is : ', kcsgrp(jcs) WRITE(numout,FMT='(a,f12.2)' ) ' src surface areas (km2) : ', psurfsrc(jcs) * 1.0e-6 WRITE(numout,FMT='(a,f12.2)' ) ' trg surface areas (km2) : ', psurftrg(jcs) * 1.0e-6 END DO ! WRITE(numout,*)'' END IF END SUBROUTINE SUBROUTINE sbc_csupdate(kncs, kcsgrp, kmsk_src, kmsk_trg, psurfsrc, psurftrg, cdcstype, kmsk_opnsea, psurf_opnsea, pwcs, pqcs) !!----------------------------------------------------------------------- !! *** routine sbc_csupdate *** !! !! ** Purpose : - compute the net freshwater fluxes over each closed seas !! - apply correction to closed sea source/target net fwf accordingly !!---------------------------------------------------------------------- ! subroutine parameters INTEGER, INTENT(in) :: kncs ! closed sea number INTEGER, DIMENSION(: ), INTENT(in) :: kcsgrp ! closed sea group number INTEGER, DIMENSION(:,:), INTENT(in) :: kmsk_src, kmsk_trg, kmsk_opnsea ! source, target, open ocean mask REAL(wp), DIMENSION(:) , INTENT(in ) :: psurfsrc, psurftrg, psurf_opnsea ! source, target and open ocean surface area REAL(wp), DIMENSION(:,:), INTENT(inout) :: pwcs, pqcs ! water and heat flux correction due to closed seas CHARACTER(256), INTENT(in ) :: cdcstype ! closed sea scheme used for redistribution ! local variables INTEGER :: jcs ! loop index over closed sea INTEGER, DIMENSION(jpi,jpj) :: imsk_src, imsk_trg ! tmp array source and target closed sea masks REAL(wp) :: zcoef, zcoef1, ztmp ! tmp REAL(wp) :: zcsfwf ! tmp net fwf over one closed sea REAL(wp) :: zsurftrg ! tmp target surface area !!---------------------------------------------------------------------- ! DO jcs = 1, kncs ! loop over closed seas ! !! 0. get mask of each closed sea imsk_src(:,:) = 0 WHERE ( kmsk_src(:,:) == jcs ) imsk_src(:,:) = 1 ! !! 1. Work out net freshwater fluxes over each closed seas from EMP - RNF. zcsfwf = glob_sum( 'closea', e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * imsk_src(:,:) ) ! !! 2. Deal with runoff special case (net evaporation spread globally) IF (cdcstype == 'rnf' .AND. zcsfwf > 0) THEN zsurftrg = psurf_opnsea(1) imsk_trg = kmsk_opnsea * kcsgrp(jcs) ! set imsk_trg value to the corresponding group id ELSE zsurftrg = psurftrg(jcs) imsk_trg = kmsk_trg END IF imsk_trg = imsk_trg * kmsk_opnsea ! !! 3. Add residuals to target points zcoef = zcsfwf / zsurftrg zcoef1 = rcp * zcoef WHERE( imsk_trg(:,:) == kcsgrp(jcs) ) pwcs(:,:) = pwcs(:,:) + zcoef pqcs(:,:) = pqcs(:,:) - zcoef1 * sst_m(:,:) ENDWHERE ! !! 4. Subtract residuals from source points zcoef = zcsfwf / psurfsrc(jcs) zcoef1 = rcp * zcoef WHERE( kmsk_src(:,:) == jcs ) pwcs(:,:) = pwcs(:,:) - zcoef pqcs(:,:) = pqcs(:,:) + zcoef1 * sst_m(:,:) ENDWHERE ! END DO ! jcs END SUBROUTINE SUBROUTINE alloc_cssurf( klen, pvarsrc, pvartrg ) !!----------------------------------------------------------------------- !! *** routine alloc_cssurf *** !! !! ** Purpose : allocate closed sea surface array (source) !!---------------------------------------------------------------------- ! subroutine parameters INTEGER, INTENT(in) :: klen REAL(wp), ALLOCATABLE, DIMENSION(:), INTENT(inout) :: pvarsrc, pvartrg ! ! local variables INTEGER :: ierr !!---------------------------------------------------------------------- ! ! klen (number of lake) can be zero so use MAX(klen,1) to avoid 0 length array ALLOCATE( pvarsrc(MAX(klen,1)) , pvartrg(MAX(klen,1)) , STAT=ierr ) IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate surf array') ! ! initialise to 0 pvarsrc(:) = 0.e0_wp pvartrg(:) = 0.e0_wp END SUBROUTINE SUBROUTINE alloc_csgrp( klen, kvar ) !!----------------------------------------------------------------------- !! *** routine alloc_csgrp *** !! !! ** Purpose : allocate closed sea group surface array !!---------------------------------------------------------------------- ! subroutine parameters INTEGER, INTENT(in) :: klen INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(inout) :: kvar ! ! local variables INTEGER :: ierr !!---------------------------------------------------------------------- ! ! klen (number of lake) can be zero so use MAX(klen,1) to avoid 0 length array ALLOCATE( kvar(MAX(klen,1)) , STAT=ierr ) IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate group array') ! initialise to 0 kvar(:) = 0 END SUBROUTINE END MODULE