Changeset 11295


Ignore:
Timestamp:
2019-07-18T15:25:07+02:00 (13 months ago)
Author:
mathiot
Message:

add sbcclo.F90 + cleaning + comments

Location:
NEMO/branches/2019/ENHANCE-03_closea/src/OCE
Files:
1 added
2 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2019/ENHANCE-03_closea/src/OCE/DOM/closea.F90

    r11207 r11295  
    3333 
    3434   IMPLICIT NONE 
    35    PRIVATE 
     35   PRIVATE read_csmask 
     36   PRIVATE alloc_csmask 
    3637 
    3738   PUBLIC dom_clo      ! called by domain module 
    38    PUBLIC sbc_clo_init ! called by sbcmod module 
    39    PUBLIC sbc_clo      ! called by sbcmod module 
    4039   PUBLIC clo_rnf      ! called by sbcrnf module 
    4140   PUBLIC clo_bat      ! called in domzgr module 
    4241 
    43    LOGICAL, PUBLIC :: ln_maskcs  !: mask all closed sea 
    44    LOGICAL, PUBLIC :: ln_mask_csundef  !: mask all closed sea 
    45    LOGICAL, PUBLIC :: ln_clo_rnf !: closed sea treated as runoff (update rnf mask) 
     42   LOGICAL, PUBLIC :: ln_maskcs        !: logical to mask all closed sea 
     43   LOGICAL, PUBLIC :: ln_mask_csundef  !: logical to mask all undefined closed sea 
     44   LOGICAL, PUBLIC :: ln_clo_rnf       !: closed sea treated as runoff (update rnf mask) 
    4645 
    4746   LOGICAL, PUBLIC :: l_sbc_clo  !: T => net evap/precip over closed seas spread outover the globe/river mouth 
    4847   LOGICAL, PUBLIC :: l_clo_rnf  !: T => Some closed seas output freshwater (RNF) to specified runoff points. 
    4948 
    50    INTEGER, PUBLIC :: jncsg      !: number of closed seas global mappings (inferred from closea_mask_glo field) 
    51    INTEGER, PUBLIC :: jncsr      !: number of closed seas rnf    mappings (inferred from closea_mask_rnf field) 
    52    INTEGER, PUBLIC :: jncse      !: number of closed seas empmr  mappings (inferred from closea_mask_emp field) 
    53  
    54    INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:)   :: jcsgrpg, jcsgrpr, jcsgrpe 
    55    
    56    INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_opnsea, mask_csundef  
     49   INTEGER, PUBLIC :: ncsg      !: number of closed seas global mappings (inferred from closea_mask_glo field) 
     50   INTEGER, PUBLIC :: ncsr      !: number of closed seas rnf    mappings (inferred from closea_mask_rnf field) 
     51   INTEGER, PUBLIC :: ncse      !: number of closed seas empmr  mappings (inferred from closea_mask_emp field) 
     52 
     53   INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_opnsea, mask_csundef !: mask defining the open sea and the undefined closed sea 
    5754  
    58    INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) ::  mask_csglo, mask_csgrpglo !: mask of integers defining closed seas 
    59    INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) ::  mask_csrnf, mask_csgrprnf !: mask of integers defining closed seas rnf mappings 
    60    INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) ::  mask_csemp, mask_csgrpemp !: mask of integers defining closed seas empmr mappings 
    61  
    62    REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcg, rsurftrgg !: closed sea target glo surface areas  
    63    REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcr, rsurftrgr !: closed sea target rnf surface areas  
    64    REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrce, rsurftrge !: closed sea target emp surface areas  
     55   INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_csglo, mask_csgrpglo !: mask of integers defining closed seas 
     56   INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_csrnf, mask_csgrprnf !: mask of integers defining closed seas rnf mappings 
     57   INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_csemp, mask_csgrpemp !: mask of integers defining closed seas empmr mappings 
    6558 
    6659   !! * Substitutions 
     
    154147         ! 
    155148         ! compute number of cs for each cases 
    156          jncsg = MAXVAL( mask_csglo(:,:) ) ; CALL mpp_max( 'closea', jncsg ) 
    157          jncsr = MAXVAL( mask_csrnf(:,:) ) ; CALL mpp_max( 'closea', jncsr ) 
    158          jncse = MAXVAL( mask_csemp(:,:) ) ; CALL mpp_max( 'closea', jncse ) 
     149         ncsg = MAXVAL( mask_csglo(:,:) ) ; CALL mpp_max( 'closea', ncsg ) 
     150         ncsr = MAXVAL( mask_csrnf(:,:) ) ; CALL mpp_max( 'closea', ncsr ) 
     151         ncse = MAXVAL( mask_csemp(:,:) ) ; CALL mpp_max( 'closea', ncse ) 
    159152         ! 
    160153         ! allocate closed sea group masks 
     
    168161         CALL read_csmask( cn_domcfg, 'mask_csgrpemp', mask_csgrpemp ) 
    169162         ! 
    170          ! Allocate cs variables (surf) 
    171          CALL alloc_cssurf( jncsg, rsurfsrcg, rsurftrgg )  
    172          CALL alloc_cssurf( jncsr, rsurfsrcr, rsurftrgr ) 
    173          CALL alloc_cssurf( jncse, rsurfsrce, rsurftrge ) 
    174          ! 
    175          ! Allocate cs group variables (jcsgrp) 
    176          CALL alloc_csgrp( jncsg, jcsgrpg ) 
    177          CALL alloc_csgrp( jncsr, jcsgrpr ) 
    178          CALL alloc_csgrp( jncse, jcsgrpe ) 
    179          ! 
    180163      END IF 
    181164   END SUBROUTINE dom_clo 
    182  
    183    SUBROUTINE sbc_clo_init 
    184  
    185       ! compute source surface area 
    186       CALL get_cssrcsurf( jncsg, mask_csglo, rsurfsrcg ) 
    187       CALL get_cssrcsurf( jncsr, mask_csrnf, rsurfsrcr ) 
    188       CALL get_cssrcsurf( jncse, mask_csemp, rsurfsrce ) 
    189       ! 
    190       ! compute target surface area and group number (jcsgrp) for all cs and cases  
    191       ! glo could be simpler but for lisibility, all treated the same way 
    192       ! It is only done once, so not a big deal 
    193       CALL get_cstrgsurf( jncsg, mask_csglo, mask_csgrpglo, rsurftrgg, jcsgrpg ) 
    194       CALL get_cstrgsurf( jncsr, mask_csrnf, mask_csgrprnf, rsurftrgr, jcsgrpr ) 
    195       CALL get_cstrgsurf( jncse, mask_csemp, mask_csgrpemp, rsurftrge, jcsgrpe ) 
    196       !  
    197       ! print out in ocean.ouput 
    198       CALL prt_csctl( jncsg, rsurfsrcg, rsurftrgg, jcsgrpg, 'glo' ) 
    199       CALL prt_csctl( jncsr, rsurfsrcr, rsurftrgr, jcsgrpr, 'rnf' ) 
    200       CALL prt_csctl( jncse, rsurfsrce, rsurftrge, jcsgrpe, 'emp' ) 
    201  
    202    END SUBROUTINE sbc_clo_init 
    203  
    204    SUBROUTINE get_cssrcsurf(kncs, pmaskcs, psurfsrc) 
    205  
    206       ! subroutine parameters 
    207       INTEGER,                 INTENT(in   ) :: kncs 
    208       INTEGER, DIMENSION(:,:), INTENT(in   ) :: pmaskcs 
    209  
    210       REAL(wp), DIMENSION(:)  , INTENT(inout) :: psurfsrc 
    211  
    212       ! local variables 
    213       INTEGER, DIMENSION(jpi,jpj) :: zmsksrc 
    214       INTEGER :: jcs 
    215  
    216       DO jcs = 1,kncs 
    217          ! 
    218          ! build river mouth mask for this lake 
    219          WHERE ( pmaskcs == jcs ) 
    220             zmsksrc = 1 
    221          ELSE WHERE 
    222             zmsksrc = 0 
    223          END WHERE 
    224          ! 
    225          ! compute target area 
    226          psurfsrc(jcs) = glob_sum('closea', e1e2t(:,:) * zmsksrc(:,:) ) 
    227          ! 
    228       END DO 
    229  
    230    END SUBROUTINE 
    231  
    232    SUBROUTINE get_cstrgsurf(kncs, pmaskcs, pmaskcsgrp, psurftrg, kcsgrp ) 
    233  
    234       ! subroutine parameters 
    235       INTEGER,               INTENT(in   ) :: kncs 
    236       INTEGER, DIMENSION(:), INTENT(inout) :: kcsgrp 
    237       INTEGER, DIMENSION(:,:), INTENT(in   ) :: pmaskcs, pmaskcsgrp 
    238  
    239       REAL(wp), DIMENSION(:)  , INTENT(inout) :: psurftrg 
    240  
    241       ! local variables 
    242       INTEGER, DIMENSION(jpi,jpj) :: zmskgrp, zmsksrc, zmsktrg 
    243       INTEGER :: jcs, jtmp 
    244  
    245       DO jcs = 1,kncs 
    246          ! 
    247          ! find group number 
    248          zmskgrp = pmaskcsgrp 
    249          zmsksrc = pmaskcs 
    250          ! 
    251          ! set value where cs is 
    252          zmsktrg = HUGE(1) 
    253          WHERE ( zmsksrc == jcs ) zmsktrg = jcs 
    254          ! 
    255          ! zmsk = HUGE outside the cs number jcs 
    256          ! ktmp = jcs - group number 
    257          ! jgrp = group corresponding to the cs jcs 
    258          zmsktrg = zmsktrg - zmskgrp 
    259          jtmp = MINVAL(zmsktrg) ; CALL mpp_min('closea',jtmp) 
    260          kcsgrp(jcs) = jcs - jtmp 
    261          ! 
    262          ! build river mouth mask for this lake 
    263          WHERE ( zmskgrp * mask_opnsea == kcsgrp(jcs) ) 
    264             zmsktrg = 1 
    265          ELSE WHERE 
    266             zmsktrg = 0 
    267          END WHERE 
    268          ! 
    269          ! compute target area 
    270          psurftrg(jcs) = glob_sum('closea', e1e2t(:,:) * zmsktrg(:,:) ) 
    271          ! 
    272       END DO 
    273  
    274    END SUBROUTINE 
    275  
    276    SUBROUTINE prt_csctl(kncs, psurfsrc, psurftrg, kcsgrp, pcstype) 
    277       ! subroutine parameters 
    278       INTEGER, INTENT(in   ) :: kncs 
    279       INTEGER, DIMENSION(:), INTENT(in   ) :: kcsgrp 
    280       ! 
    281       REAL(wp), DIMENSION(:), INTENT(in   ) :: psurfsrc, psurftrg 
    282       ! 
    283       CHARACTER(256), INTENT(in   ) :: pcstype 
    284       ! 
    285       ! local variable 
    286       INTEGER :: jcs 
    287        
    288       IF ( lwp .AND. kncs > 0 ) THEN 
    289          WRITE(numout,*)'' 
    290          ! 
    291          WRITE(numout,*)'Closed sea target ',TRIM(pcstype),' : ' 
    292          ! 
    293          DO jcs = 1,kncs 
    294             WRITE(numout,FMT='(3a,i3,a,i3)') ' ',TRIM(pcstype),' closed sea id is ',jcs,' and trg id is : ', kcsgrp(jcs) 
    295             WRITE(numout,FMT='(a,f12.2)'   ) ' src surface areas (km2) : ', psurfsrc(jcs) * 1.0e-6 
    296             WRITE(numout,FMT='(a,f12.2)'   ) ' trg surface areas (km2) : ', psurftrg(jcs) * 1.0e-6 
    297          END DO 
    298          ! 
    299          WRITE(numout,*)'' 
    300       END IF 
    301    END SUBROUTINE 
    302  
    303    SUBROUTINE sbc_clo( kt ) ! to be move in SBC in a file sbcclo ??? 
    304       !!--------------------------------------------------------------------- 
    305       !!                  ***  ROUTINE sbc_clo  *** 
    306       !!                     
    307       !! ** Purpose :   Special handling of closed seas 
    308       !! 
    309       !! ** Method  :   Water flux is forced to zero over closed sea 
    310       !!      Excess is shared between remaining ocean, or 
    311       !!      put as run-off in open ocean. 
    312       !! 
    313       !! ** Action  :   emp updated surface freshwater fluxes and associated heat content at kt 
    314       !!---------------------------------------------------------------------- 
    315       INTEGER         , INTENT(in   ) ::   kt       ! ocean model time step 
    316       !!---------------------------------------------------------------------- 
    317       ! 
    318       IF( ln_timing )  CALL timing_start('sbc_clo') 
    319       ! 
    320       ! update emp and qns 
    321       CALL sbc_csupdate( jncsg, jcsgrpg, mask_csglo, mask_csgrpglo, rsurfsrcg, rsurftrgg, 'glo', mask_opnsea, rsurftrgg ) 
    322       CALL sbc_csupdate( jncsr, jcsgrpr, mask_csrnf, mask_csgrprnf, rsurfsrcr, rsurftrgr, 'rnf', mask_opnsea, rsurftrgg ) 
    323       CALL sbc_csupdate( jncse, jcsgrpe, mask_csemp, mask_csgrpemp, rsurfsrce, rsurftrge, 'emp', mask_opnsea, rsurftrgg ) 
    324       ! 
    325       ! is this really useful ?????? 
    326       emp(:,:) = emp(:,:) * tmask(:,:,1) 
    327       qns(:,:) = qns(:,:) * tmask(:,:,1) 
    328       ! 
    329       ! is this really useful ?????? 
    330       CALL lbc_lnk( 'closea', emp , 'T', 1._wp ) 
    331       CALL lbc_lnk( 'closea', qns , 'T', 1._wp ) 
    332       ! 
    333    END SUBROUTINE sbc_clo 
    334     
    335    SUBROUTINE sbc_csupdate(kncs, kcsgrp, pmsk_src, pmsk_trg, psurfsrc, psurftrg, pcstype, pmsk_opnsea, psurf_opnsea) 
    336  
    337       ! subroutine parameters 
    338       INTEGER, INTENT(in   ) :: kncs 
    339       INTEGER, DIMENSION(:  ), INTENT(in   ) :: kcsgrp 
    340       INTEGER, DIMENSION(:,:), INTENT(in   ) :: pmsk_src, pmsk_trg, pmsk_opnsea 
    341        
    342       REAL(wp), DIMENSION(:), INTENT(inout) :: psurfsrc, psurftrg, psurf_opnsea 
    343  
    344       CHARACTER(256), INTENT(in   ) :: pcstype 
    345  
    346       ! local variables 
    347       INTEGER :: jcs 
    348       INTEGER, DIMENSION(jpi,jpj) :: zmsk_src, zmsk_trg 
    349        
    350       REAL(wp) :: zcoef, zcoef1, ztmp 
    351       REAL(wp) :: zcsfwf 
    352       REAL(wp) :: zsurftrg 
    353       
    354       DO jcs = 1, kncs 
    355          !! 
    356          !! 0. get mask of each closed sea 
    357          zmsk_src(:,:) = 0 
    358          WHERE ( pmsk_src(:,:) == jcs ) zmsk_src = 1 
    359          !! 
    360          !! 1. Work out net freshwater fluxes over each closed seas from EMP - RNF. 
    361          zcsfwf = glob_sum( 'closea', e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * zmsk_src ) 
    362          !! 
    363          !! 2. Deal with runoff special case (net evaporation spread globally) 
    364          IF (pcstype == 'rnf' .AND. zcsfwf > 0) THEN 
    365             zsurftrg = psurf_opnsea(1) 
    366             zmsk_trg = pmsk_opnsea 
    367          ELSE 
    368             zsurftrg = psurftrg(jcs) 
    369             zmsk_trg = pmsk_trg 
    370          END IF 
    371          zmsk_trg = zmsk_trg * pmsk_opnsea 
    372          !! 
    373          !! 3. Add residuals to target points 
    374          zcoef    = zcsfwf / zsurftrg 
    375          zcoef1   = rcp * zcoef 
    376          WHERE( zmsk_trg(:,:) == kcsgrp(jcs) ) 
    377             emp(:,:) = emp(:,:) + zcoef 
    378             qns(:,:) = qns(:,:) - zcoef1 * sst_m(:,:) 
    379          ENDWHERE 
    380          !! 
    381          !! 4. Subtract residuals from source points 
    382          zcoef    = zcsfwf / psurfsrc(jcs) 
    383          zcoef1   = rcp * zcoef 
    384          WHERE( pmsk_src(:,:) == jcs ) 
    385             emp(:,:) = emp(:,:) - zcoef 
    386             qns(:,:) = qns(:,:) + zcoef1 * sst_m(:,:) 
    387          ENDWHERE 
    388          !! 
    389       END DO ! jcs 
    390  
    391    END SUBROUTINE 
    392  
    393165 
    394166   SUBROUTINE clo_rnf( p_rnfmsk ) 
     
    420192   END SUBROUTINE clo_rnf 
    421193       
    422    SUBROUTINE clo_bat( k_top, k_bot, p_mask, p_prt ) 
     194   SUBROUTINE clo_bat( k_top, k_bot, k_mask, cd_prt ) 
    423195      !!--------------------------------------------------------------------- 
    424196      !!                  ***  ROUTINE clo_bat  *** 
     
    436208      !! subroutine parameter 
    437209      INTEGER, DIMENSION(:,:), INTENT(inout) ::   k_top, k_bot   ! ocean first and last level indices 
    438       INTEGER, DIMENSION(:,:), INTENT(in   ) ::   p_mask         ! mask used to mask ktop and k_bot 
    439       CHARACTER(256),          INTENT(in   ) ::   p_prt          ! text for control print 
     210      INTEGER, DIMENSION(:,:), INTENT(in   ) ::   k_mask         ! mask used to mask ktop and k_bot 
     211      CHARACTER(256),          INTENT(in   ) ::   cd_prt         ! text for control print 
    440212      !! 
    441213      !! local variables 
     
    444216      IF ( lwp ) THEN 
    445217         WRITE(numout,*) 
    446          WRITE(numout,*) 'clo_bat : Suppression closed seas based on ',TRIM(p_prt),' field.' 
     218         WRITE(numout,*) 'clo_bat : Suppression closed seas based on ',TRIM(cd_prt),' field.' 
    447219         WRITE(numout,*) '~~~~~~~' 
    448220         WRITE(numout,*) 
    449221      ENDIF 
    450222      !! 
    451       k_top(:,:) = k_top(:,:) * p_mask(:,:) 
    452       k_bot(:,:) = k_bot(:,:) * p_mask(:,:) 
     223      k_top(:,:) = k_top(:,:) * k_mask(:,:) 
     224      k_bot(:,:) = k_bot(:,:) * k_mask(:,:) 
    453225      !! 
    454226   END SUBROUTINE clo_bat 
    455227 
    456    SUBROUTINE read_csmask(p_file, p_var, p_mskout) 
     228   SUBROUTINE read_csmask(cd_file, cd_var, k_mskout) 
    457229      ! 
    458230      ! subroutine parameter 
    459       CHARACTER(256), INTENT(in   ) :: p_file, p_var 
    460       INTEGER, DIMENSION(:,:), INTENT(inout) :: p_mskout 
     231      CHARACTER(256), INTENT(in   ) :: cd_file, cd_var     ! netcdf file and variable name 
     232      INTEGER, DIMENSION(:,:), INTENT(inout) :: k_mskout ! output mask variable 
    461233      ! 
    462234      ! local variables 
    463       INTEGER :: ics 
    464       REAL(wp), DIMENSION(jpi,jpj) :: zdta 
    465       ! 
    466       CALL iom_open ( p_file, ics ) 
    467       CALL iom_get  ( ics, jpdom_data, TRIM(p_var), zdta ) 
     235      INTEGER :: ics                       ! netcdf id 
     236      REAL(wp), DIMENSION(jpi,jpj) :: zdta ! netcdf data 
     237      ! 
     238      CALL iom_open ( cd_file, ics ) 
     239      CALL iom_get  ( ics, jpdom_data, TRIM(cd_var), zdta ) 
    468240      CALL iom_close( ics ) 
    469       p_mskout(:,:) = NINT(zdta(:,:)) 
     241      k_mskout(:,:) = NINT(zdta(:,:)) 
    470242      ! 
    471243   END SUBROUTINE read_csmask 
    472244 
    473    SUBROUTINE alloc_csmask( pmask ) 
     245   SUBROUTINE alloc_csmask( kmask ) 
    474246      ! 
    475247      ! subroutine parameter 
    476       INTEGER, ALLOCATABLE, DIMENSION(:,:), INTENT(inout) :: pmask 
     248      INTEGER, ALLOCATABLE, DIMENSION(:,:), INTENT(inout) :: kmask 
    477249      ! 
    478250      ! local variables 
    479251      INTEGER :: ierr 
    480252      ! 
    481       ALLOCATE( pmask(jpi,jpj) , STAT=ierr ) 
     253      ALLOCATE( kmask(jpi,jpj) , STAT=ierr ) 
    482254      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'alloc_csmask: failed to allocate surf array') 
    483255      ! 
    484256   END SUBROUTINE 
    485257 
    486  
    487    SUBROUTINE alloc_cssurf( klen, pvarsrc, pvartrg ) 
    488       ! 
    489       ! subroutine parameter 
    490       INTEGER, INTENT(in) :: klen 
    491       REAL(wp), ALLOCATABLE, DIMENSION(:), INTENT(inout) :: pvarsrc, pvartrg  
    492       ! 
    493       ! local variables 
    494       INTEGER :: ierr 
    495       ! 
    496       ! klen (number of lake) can be zero so use MAX(klen,1) to avoid 0 length array 
    497       ALLOCATE( pvarsrc(MAX(klen,1)) , pvartrg(MAX(klen,1)) , STAT=ierr ) 
    498       IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate surf array') 
    499       ! initialise to 0 
    500       pvarsrc(:) = 0.e0_wp 
    501       pvartrg(:) = 0.e0_wp 
    502    END SUBROUTINE 
    503  
    504    SUBROUTINE alloc_csgrp( klen, kvar ) 
    505       ! 
    506       ! subroutine parameter 
    507       INTEGER, INTENT(in) :: klen 
    508       INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(inout) :: kvar  
    509       ! 
    510       ! local variables 
    511       INTEGER :: ierr 
    512       ! 
    513       ! klen (number of lake) can be zero so use MAX(klen,1) to avoid 0 length array 
    514       ALLOCATE( kvar(MAX(klen,1)) , STAT=ierr ) 
    515       IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate group array') 
    516       ! initialise to 0 
    517       kvar(:) = 0 
    518    END SUBROUTINE 
    519  
    520    !!====================================================================== 
    521258END MODULE closea 
    522  
  • NEMO/branches/2019/ENHANCE-03_closea/src/OCE/SBC/sbcmod.F90

    r11207 r11295  
    4141   USE sbccpl         ! surface boundary condition: coupled formulation 
    4242   USE cpl_oasis3     ! OASIS routines for coupling 
     43   USE sbcclo         ! surface boundary condition: closed sea correction 
    4344   USE sbcssr         ! surface boundary condition: sea surface restoring 
    4445   USE sbcrnf         ! surface boundary condition: runoffs 
Note: See TracChangeset for help on using the changeset viewer.