diff --git a/MY_SRC/bdyini.F90 b/MY_SRC/bdyini.F90 deleted file mode 100755 index 3bddb56..0000000 --- a/MY_SRC/bdyini.F90 +++ /dev/null @@ -1,1793 +0,0 @@ -MODULE bdyini - !!====================================================================== - !! *** MODULE bdyini *** - !! Unstructured open boundaries : initialisation - !!====================================================================== - !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code - !! - ! 2007-01 (D. Storkey) Update to use IOM module - !! - ! 2007-01 (D. Storkey) Tidal forcing - !! 3.0 ! 2008-04 (NEMO team) add in the reference version - !! 3.3 ! 2010-09 (E.O'Dea) updates for Shelf configurations - !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions - !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge - !! 3.4 ! 2012 (J. Chanut) straight open boundary case update - !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) optimization of BDY communications - !! 3.7 ! 2016 (T. Lovato) Remove bdy macro, call here init for dta and tides - !!---------------------------------------------------------------------- - !! bdy_init : Initialization of unstructured open boundaries - !!---------------------------------------------------------------------- - USE oce ! ocean dynamics and tracers variables - USE dom_oce ! ocean space and time domain - USE bdy_oce ! unstructured open boundary conditions - USE bdydta ! open boundary cond. setting (bdy_dta_init routine) - USE bdytides ! open boundary cond. setting (bdytide_init routine) - USE sbctide ! Tidal forcing or not - USE phycst , ONLY: rday - ! - USE in_out_manager ! I/O units - USE lbclnk ! ocean lateral boundary conditions (or mpp link) - USE lib_mpp ! for mpp_sum - USE iom ! I/O - - IMPLICIT NONE - PRIVATE - - PUBLIC bdy_init ! routine called in nemo_init - PUBLIC find_neib ! routine called in bdy_nmn - - INTEGER, PARAMETER :: jp_nseg = 100 ! - ! Straight open boundary segment parameters: - INTEGER :: nbdysege, nbdysegw, nbdysegn, nbdysegs - INTEGER, DIMENSION(jp_nseg) :: jpieob, jpjedt, jpjeft, npckge ! - INTEGER, DIMENSION(jp_nseg) :: jpiwob, jpjwdt, jpjwft, npckgw ! - INTEGER, DIMENSION(jp_nseg) :: jpjnob, jpindt, jpinft, npckgn ! - INTEGER, DIMENSION(jp_nseg) :: jpjsob, jpisdt, jpisft, npckgs ! - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: bdyini.F90 12142 2019-12-10 11:50:13Z smasson $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE bdy_init - !!---------------------------------------------------------------------- - !! *** ROUTINE bdy_init *** - !! - !! ** Purpose : Initialization of the dynamics and tracer fields with - !! unstructured open boundaries. - !! - !! ** Method : Read initialization arrays (mask, indices) to identify - !! an unstructured open boundary - !! - !! ** Input : bdy_init.nc, input file for unstructured open boundaries - !!---------------------------------------------------------------------- - NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & - & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & - & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & - & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & - & cn_ice, nn_ice_dta, & - & ln_vol, nn_volctl, nn_rimwidth - ! - INTEGER :: ios ! Local integer output status for namelist read - !!---------------------------------------------------------------------- - - ! ------------------------ - ! Read namelist parameters - ! ------------------------ - REWIND( numnam_ref ) ! Namelist nambdy in reference namelist :Unstructured open boundaries - READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 901) -901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' ) - ! make sur that all elements of the namelist variables have a default definition from namelist_ref - ln_coords_file (2:jp_bdy) = ln_coords_file (1) - cn_coords_file (2:jp_bdy) = cn_coords_file (1) - cn_dyn2d (2:jp_bdy) = cn_dyn2d (1) - nn_dyn2d_dta (2:jp_bdy) = nn_dyn2d_dta (1) - cn_dyn3d (2:jp_bdy) = cn_dyn3d (1) - nn_dyn3d_dta (2:jp_bdy) = nn_dyn3d_dta (1) - cn_tra (2:jp_bdy) = cn_tra (1) - nn_tra_dta (2:jp_bdy) = nn_tra_dta (1) - ln_tra_dmp (2:jp_bdy) = ln_tra_dmp (1) - ln_dyn3d_dmp (2:jp_bdy) = ln_dyn3d_dmp (1) - rn_time_dmp (2:jp_bdy) = rn_time_dmp (1) - rn_time_dmp_out(2:jp_bdy) = rn_time_dmp_out(1) - cn_ice (2:jp_bdy) = cn_ice (1) - nn_ice_dta (2:jp_bdy) = nn_ice_dta (1) - REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist :Unstructured open boundaries - READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 902 ) -902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' ) - IF(lwm) WRITE ( numond, nambdy ) - - IF( .NOT. Agrif_Root() ) ln_bdy = .FALSE. ! forced for Agrif children - - IF( nb_bdy == 0 ) ln_bdy = .FALSE. - - ! ----------------------------------------- - ! unstructured open boundaries use control - ! ----------------------------------------- - IF ( ln_bdy ) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'bdy_init : initialization of open boundaries' - IF(lwp) WRITE(numout,*) '~~~~~~~~' - ! - ! Open boundaries definition (arrays and masks) - CALL bdy_def - IF( ln_meshmask ) CALL bdy_meshwri() - ! - ! Open boundaries initialisation of external data arrays - CALL bdy_dta_init - ! - ! Open boundaries initialisation of tidal harmonic forcing - IF( ln_tide ) CALL bdytide_init - ! - ELSE - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'bdy_init : open boundaries not used (ln_bdy = F)' - IF(lwp) WRITE(numout,*) '~~~~~~~~' - ! - ENDIF - ! - END SUBROUTINE bdy_init - - - SUBROUTINE bdy_def - !!---------------------------------------------------------------------- - !! *** ROUTINE bdy_init *** - !! - !! ** Purpose : Definition of unstructured open boundaries. - !! - !! ** Method : Read initialization arrays (mask, indices) to identify - !! an unstructured open boundary - !! - !! ** Input : bdy_init.nc, input file for unstructured open boundaries - !!---------------------------------------------------------------------- - INTEGER :: ib_bdy, ii, ij, igrd, ib, ir, iseg ! dummy loop indices - INTEGER :: icount, icountr, icountr0, ibr_max ! local integers - INTEGER :: ilen1 ! - - - INTEGER :: iwe, ies, iso, ino, inum, id_dummy ! - - - INTEGER :: jpbdta ! - - - INTEGER :: ib_bdy1, ib_bdy2, ib1, ib2 ! - - - INTEGER :: ii1, ii2, ii3, ij1, ij2, ij3 ! - - - INTEGER :: iibe, ijbe, iibi, ijbi ! - - - INTEGER :: flagu, flagv ! short cuts - INTEGER :: nbdyind, nbdybeg, nbdyend - INTEGER , DIMENSION(4) :: kdimsz - INTEGER , DIMENSION(jpbgrd,jp_bdy) :: nblendta ! Length of index arrays - INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbidta, nbjdta ! Index arrays: i and j indices of bdy dta - INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbrdta ! Discrete distance from rim points - CHARACTER(LEN=1) , DIMENSION(jpbgrd) :: cgrid - REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zz_read ! work space for 2D global boundary data - REAL(wp), POINTER , DIMENSION(:,:) :: zmask ! pointer to 2D mask fields - REAL(wp) , DIMENSION(jpi,jpj) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) - REAL(wp) , DIMENSION(jpi,jpj) :: ztmask, zumask, zvmask ! temporary u/v mask array - !!---------------------------------------------------------------------- - ! - cgrid = (/'t','u','v'/) - - ! ----------------------------------------- - ! Check and write out namelist parameters - ! ----------------------------------------- -! IF( jperio /= 0 ) CALL ctl_stop( 'bdy_segs: Cyclic or symmetric,', & -! & ' and general open boundary condition are not compatible' ) - - IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy - - DO ib_bdy = 1,nb_bdy - - IF(lwp) THEN - WRITE(numout,*) ' ' - WRITE(numout,*) '------ Open boundary data set ',ib_bdy,' ------' - IF( ln_coords_file(ib_bdy) ) THEN - WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_bdy)) - ELSE - WRITE(numout,*) 'Boundary defined in namelist.' - ENDIF - WRITE(numout,*) - ENDIF - - ! barotropic bdy - !---------------- - IF(lwp) THEN - WRITE(numout,*) 'Boundary conditions for barotropic solution: ' - SELECT CASE( cn_dyn2d(ib_bdy) ) - CASE( 'none' ) ; WRITE(numout,*) ' no open boundary condition' - CASE( 'frs' ) ; WRITE(numout,*) ' Flow Relaxation Scheme' - CASE( 'flather' ) ; WRITE(numout,*) ' Flather radiation condition' - CASE( 'orlanski' ) ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' - CASE( 'orlanski_npo' ) ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' - CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn2d' ) - END SELECT - ENDIF - - dta_bdy(ib_bdy)%lneed_ssh = cn_dyn2d(ib_bdy) == 'flather' - dta_bdy(ib_bdy)%lneed_dyn2d = cn_dyn2d(ib_bdy) /= 'none' - - IF( lwp .AND. dta_bdy(ib_bdy)%lneed_dyn2d ) THEN - SELECT CASE( nn_dyn2d_dta(ib_bdy) ) ! - CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' - CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' - CASE( 2 ) ; WRITE(numout,*) ' tidal harmonic forcing taken from file' - CASE( 3 ) ; WRITE(numout,*) ' boundary data AND tidal harmonic forcing taken from files' - CASE DEFAULT ; CALL ctl_stop( 'nn_dyn2d_dta must be between 0 and 3' ) - END SELECT - ENDIF - IF ( dta_bdy(ib_bdy)%lneed_dyn2d .AND. nn_dyn2d_dta(ib_bdy) .GE. 2 .AND. .NOT.ln_tide ) THEN - CALL ctl_stop( 'You must activate with ln_tide to add tidal forcing at open boundaries' ) - ENDIF - IF(lwp) WRITE(numout,*) - - ! baroclinic bdy - !---------------- - IF(lwp) THEN - WRITE(numout,*) 'Boundary conditions for baroclinic velocities: ' - SELECT CASE( cn_dyn3d(ib_bdy) ) - CASE('none') ; WRITE(numout,*) ' no open boundary condition' - CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' - CASE('specified') ; WRITE(numout,*) ' Specified value' - CASE('neumann') ; WRITE(numout,*) ' Neumann conditions' - CASE('zerograd') ; WRITE(numout,*) ' Zero gradient for baroclinic velocities' - CASE('zero') ; WRITE(numout,*) ' Zero baroclinic velocities (runoff case)' - CASE('orlanski') ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' - CASE('orlanski_npo') ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' - CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn3d' ) - END SELECT - ENDIF - - dta_bdy(ib_bdy)%lneed_dyn3d = cn_dyn3d(ib_bdy) == 'frs' .OR. cn_dyn3d(ib_bdy) == 'specified' & - & .OR. cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo' - - IF( lwp .AND. dta_bdy(ib_bdy)%lneed_dyn3d ) THEN - SELECT CASE( nn_dyn3d_dta(ib_bdy) ) ! - CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' - CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' - CASE DEFAULT ; CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' ) - END SELECT - END IF - - IF ( ln_dyn3d_dmp(ib_bdy) ) THEN - IF ( cn_dyn3d(ib_bdy) == 'none' ) THEN - IF(lwp) WRITE(numout,*) 'No open boundary condition for baroclinic velocities: ln_dyn3d_dmp is set to .false.' - ln_dyn3d_dmp(ib_bdy) = .false. - ELSEIF ( cn_dyn3d(ib_bdy) == 'frs' ) THEN - CALL ctl_stop( 'Use FRS OR relaxation' ) - ELSE - IF(lwp) WRITE(numout,*) ' + baroclinic velocities relaxation zone' - IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days' - IF(rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) - dta_bdy(ib_bdy)%lneed_dyn3d = .TRUE. - ENDIF - ELSE - IF(lwp) WRITE(numout,*) ' NO relaxation on baroclinic velocities' - ENDIF - IF(lwp) WRITE(numout,*) - - ! tra bdy - !---------------- - IF(lwp) THEN - WRITE(numout,*) 'Boundary conditions for temperature and salinity: ' - SELECT CASE( cn_tra(ib_bdy) ) - CASE('none') ; WRITE(numout,*) ' no open boundary condition' - CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' - CASE('specified') ; WRITE(numout,*) ' Specified value' - CASE('neumann') ; WRITE(numout,*) ' Neumann conditions' - CASE('runoff') ; WRITE(numout,*) ' Runoff conditions : Neumann for T and specified to 0.1 for salinity' - CASE('orlanski') ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' - CASE('orlanski_npo') ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' - CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_tra' ) - END SELECT - ENDIF - - dta_bdy(ib_bdy)%lneed_tra = cn_tra(ib_bdy) == 'frs' .OR. cn_tra(ib_bdy) == 'specified' & - & .OR. cn_tra(ib_bdy) == 'orlanski' .OR. cn_tra(ib_bdy) == 'orlanski_npo' - - IF( lwp .AND. dta_bdy(ib_bdy)%lneed_tra ) THEN - SELECT CASE( nn_tra_dta(ib_bdy) ) ! - CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' - CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' - CASE DEFAULT ; CALL ctl_stop( 'nn_tra_dta must be 0 or 1' ) - END SELECT - ENDIF - - IF ( ln_tra_dmp(ib_bdy) ) THEN - IF ( cn_tra(ib_bdy) == 'none' ) THEN - IF(lwp) WRITE(numout,*) 'No open boundary condition for tracers: ln_tra_dmp is set to .false.' - ln_tra_dmp(ib_bdy) = .false. - ELSEIF ( cn_tra(ib_bdy) == 'frs' ) THEN - CALL ctl_stop( 'Use FRS OR relaxation' ) - ELSE - IF(lwp) WRITE(numout,*) ' + T/S relaxation zone' - IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days' - IF(lwp) WRITE(numout,*) ' Outflow damping time scale: ',rn_time_dmp_out(ib_bdy),' days' - IF(lwp.AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) - dta_bdy(ib_bdy)%lneed_tra = .TRUE. - ENDIF - ELSE - IF(lwp) WRITE(numout,*) ' NO T/S relaxation' - ENDIF - IF(lwp) WRITE(numout,*) - -#if defined key_si3 - IF(lwp) THEN - WRITE(numout,*) 'Boundary conditions for sea ice: ' - SELECT CASE( cn_ice(ib_bdy) ) - CASE('none') ; WRITE(numout,*) ' no open boundary condition' - CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' - CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice' ) - END SELECT - ENDIF - - dta_bdy(ib_bdy)%lneed_ice = cn_ice(ib_bdy) /= 'none' - - IF( lwp .AND. dta_bdy(ib_bdy)%lneed_ice ) THEN - SELECT CASE( nn_ice_dta(ib_bdy) ) ! - CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' - CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' - CASE DEFAULT ; CALL ctl_stop( 'nn_ice_dta must be 0 or 1' ) - END SELECT - ENDIF -#else - dta_bdy(ib_bdy)%lneed_ice = .FALSE. -#endif - ! - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' Width of relaxation zone = ', nn_rimwidth(ib_bdy) - IF(lwp) WRITE(numout,*) - ! - END DO ! nb_bdy - - IF( lwp ) THEN - IF( ln_vol ) THEN ! check volume conservation (nn_volctl value) - WRITE(numout,*) 'Volume correction applied at open boundaries' - WRITE(numout,*) - SELECT CASE ( nn_volctl ) - CASE( 1 ) ; WRITE(numout,*) ' The total volume will be constant' - CASE( 0 ) ; WRITE(numout,*) ' The total volume will vary according to the surface E-P flux' - CASE DEFAULT ; CALL ctl_stop( 'nn_volctl must be 0 or 1' ) - END SELECT - WRITE(numout,*) - ! - ! sanity check if used with tides - IF( ln_tide ) THEN - WRITE(numout,*) ' The total volume correction is not working with tides. ' - WRITE(numout,*) ' Set ln_vol to .FALSE. ' - WRITE(numout,*) ' or ' - WRITE(numout,*) ' equilibriate your bdy input files ' - CALL ctl_stop( 'The total volume correction is not working with tides.' ) - END IF - ELSE - WRITE(numout,*) 'No volume correction applied at open boundaries' - WRITE(numout,*) - ENDIF - ENDIF - - ! ------------------------------------------------- - ! Initialise indices arrays for open boundaries - ! ------------------------------------------------- - - REWIND( numnam_cfg ) - nblendta(:,:) = 0 - nbdysege = 0 - nbdysegw = 0 - nbdysegn = 0 - nbdysegs = 0 - - ! Define all boundaries - ! --------------------- - DO ib_bdy = 1, nb_bdy - ! - IF( .NOT. ln_coords_file(ib_bdy) ) THEN ! build bdy coordinates with segments defined in namelist - - CALL bdy_read_seg( ib_bdy, nblendta(:,ib_bdy) ) - - ELSE ! Read size of arrays in boundary coordinates file. - - CALL iom_open( cn_coords_file(ib_bdy), inum ) - DO igrd = 1, jpbgrd - id_dummy = iom_varid( inum, 'nbi'//cgrid(igrd), kdimsz=kdimsz ) - nblendta(igrd,ib_bdy) = MAXVAL(kdimsz) - END DO - CALL iom_close( inum ) - ENDIF - ! - END DO ! ib_bdy - - ! Now look for crossings in user (namelist) defined open boundary segments: - IF( nbdysege > 0 .OR. nbdysegw > 0 .OR. nbdysegn > 0 .OR. nbdysegs > 0) CALL bdy_ctl_seg - - ! Allocate arrays - !--------------- - jpbdta = MAXVAL(nblendta(1:jpbgrd,1:nb_bdy)) - ALLOCATE( nbidta(jpbdta, jpbgrd, nb_bdy), nbjdta(jpbdta, jpbgrd, nb_bdy), nbrdta(jpbdta, jpbgrd, nb_bdy) ) - nbrdta(:,:,:) = 0 ! initialize nbrdta as it may not be completely defined for each bdy - - ! Calculate global boundary index arrays or read in from file - !------------------------------------------------------------ - ! 1. Read global index arrays from boundary coordinates file. - DO ib_bdy = 1, nb_bdy - ! - IF( ln_coords_file(ib_bdy) ) THEN - ! - ALLOCATE( zz_read( MAXVAL(nblendta), 1 ) ) - CALL iom_open( cn_coords_file(ib_bdy), inum ) - ! - DO igrd = 1, jpbgrd - CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) - DO ii = 1,nblendta(igrd,ib_bdy) - nbidta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) - END DO - CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) - DO ii = 1,nblendta(igrd,ib_bdy) - nbjdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) - END DO - CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) - DO ii = 1,nblendta(igrd,ib_bdy) - nbrdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) - END DO - ! - ibr_max = MAXVAL( nbrdta(:,igrd,ib_bdy) ) - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' Maximum rimwidth in file is ', ibr_max - IF(lwp) WRITE(numout,*) ' nn_rimwidth from namelist is ', nn_rimwidth(ib_bdy) - IF (ibr_max < nn_rimwidth(ib_bdy)) & - CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_bdy) ) - END DO - ! - CALL iom_close( inum ) - DEALLOCATE( zz_read ) - ! - ENDIF - ! - END DO - - ! 2. Now fill indices corresponding to straight open boundary arrays: - CALL bdy_coords_seg( nbidta, nbjdta, nbrdta ) - - ! Deal with duplicated points - !----------------------------- - ! We assign negative indices to duplicated points (to remove them from bdy points to be updated) - ! if their distance to the bdy is greater than the other - ! If their distance are the same, just keep only one to avoid updating a point twice - DO igrd = 1, jpbgrd - DO ib_bdy1 = 1, nb_bdy - DO ib_bdy2 = 1, nb_bdy - IF (ib_bdy1/=ib_bdy2) THEN - DO ib1 = 1, nblendta(igrd,ib_bdy1) - DO ib2 = 1, nblendta(igrd,ib_bdy2) - IF ((nbidta(ib1, igrd, ib_bdy1)==nbidta(ib2, igrd, ib_bdy2)).AND. & - & (nbjdta(ib1, igrd, ib_bdy1)==nbjdta(ib2, igrd, ib_bdy2))) THEN - ! IF ((lwp).AND.(igrd==1)) WRITE(numout,*) ' found coincident point ji, jj:', & - ! & nbidta(ib1, igrd, ib_bdy1), & - ! & nbjdta(ib2, igrd, ib_bdy2) - ! keep only points with the lowest distance to boundary: - IF (nbrdta(ib1, igrd, ib_bdy1)nbrdta(ib2, igrd, ib_bdy2)) THEN - nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 - nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 - ! Arbitrary choice if distances are the same: - ELSE - nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 - nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 - ENDIF - END IF - END DO - END DO - ENDIF - END DO - END DO - END DO - ! - ! Find lenght of boundaries and rim on local mpi domain - !------------------------------------------------------ - ! - iwe = mig(1) - ies = mig(jpi) - iso = mjg(1) - ino = mjg(jpj) - ! - DO ib_bdy = 1, nb_bdy - DO igrd = 1, jpbgrd - icount = 0 ! initialization of local bdy length - icountr = 0 ! initialization of local rim 0 and rim 1 bdy length - icountr0 = 0 ! initialization of local rim 0 bdy length - idx_bdy(ib_bdy)%nblen(igrd) = 0 - idx_bdy(ib_bdy)%nblenrim(igrd) = 0 - idx_bdy(ib_bdy)%nblenrim0(igrd) = 0 - DO ib = 1, nblendta(igrd,ib_bdy) - ! check that data is in correct order in file - IF( ib > 1 ) THEN - IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ib-1,igrd,ib_bdy) ) THEN - CALL ctl_stop('bdy_segs : ERROR : boundary data in file must be defined ', & - & ' in order of distance from edge nbr A utility for re-ordering ', & - & ' boundary coordinates and data files exists in the TOOLS/OBC directory') - ENDIF - ENDIF - ! check if point is in local domain - IF( nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND. & - & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino ) THEN - ! - icount = icount + 1 - IF( nbrdta(ib,igrd,ib_bdy) == 1 .OR. nbrdta(ib,igrd,ib_bdy) == 0 ) icountr = icountr + 1 - IF( nbrdta(ib,igrd,ib_bdy) == 0 ) icountr0 = icountr0 + 1 - ENDIF - END DO - idx_bdy(ib_bdy)%nblen (igrd) = icount !: length of boundary data on each proc - idx_bdy(ib_bdy)%nblenrim (igrd) = icountr !: length of rim 0 and rim 1 boundary data on each proc - idx_bdy(ib_bdy)%nblenrim0(igrd) = icountr0 !: length of rim 0 boundary data on each proc - END DO ! igrd - - ! Allocate index arrays for this boundary set - !-------------------------------------------- - ilen1 = MAXVAL( idx_bdy(ib_bdy)%nblen(:) ) - ALLOCATE( idx_bdy(ib_bdy)%nbi (ilen1,jpbgrd) , & - & idx_bdy(ib_bdy)%nbj (ilen1,jpbgrd) , & - & idx_bdy(ib_bdy)%nbr (ilen1,jpbgrd) , & - & idx_bdy(ib_bdy)%nbd (ilen1,jpbgrd) , & - & idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) , & - & idx_bdy(ib_bdy)%ntreat(ilen1,jpbgrd) , & - & idx_bdy(ib_bdy)%nbmap (ilen1,jpbgrd) , & - & idx_bdy(ib_bdy)%nbw (ilen1,jpbgrd) , & - & idx_bdy(ib_bdy)%flagu (ilen1,jpbgrd) , & - & idx_bdy(ib_bdy)%flagv (ilen1,jpbgrd) ) - - ! Dispatch mapping indices and discrete distances on each processor - ! ----------------------------------------------------------------- - DO igrd = 1, jpbgrd - icount = 0 - ! Outer loop on rimwidth to ensure outermost points come first in the local arrays. - DO ir = 0, nn_rimwidth(ib_bdy) - DO ib = 1, nblendta(igrd,ib_bdy) - ! check if point is in local domain and equals ir - IF( nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND. & - & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino .AND. & - & nbrdta(ib,igrd,ib_bdy) == ir ) THEN - ! - icount = icount + 1 - idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy)- mig(1)+1 ! global to local indexes - idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 ! global to local indexes - idx_bdy(ib_bdy)%nbr(icount,igrd) = nbrdta(ib,igrd,ib_bdy) - idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib - ENDIF - END DO - END DO - END DO ! igrd - - END DO ! ib_bdy - - ! Initialize array indicating communications in bdy - ! ------------------------------------------------- - ALLOCATE( lsend_bdy(nb_bdy,jpbgrd,4,0:1), lrecv_bdy(nb_bdy,jpbgrd,4,0:1) ) - lsend_bdy(:,:,:,:) = .false. - lrecv_bdy(:,:,:,:) = .false. - - DO ib_bdy = 1, nb_bdy - DO igrd = 1, jpbgrd - DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! only the rim triggers communications, see bdy routines - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - IF( ib .LE. idx_bdy(ib_bdy)%nblenrim0(igrd) ) THEN ; ir = 0 - ELSE ; ir = 1 - END IF - ! - ! check if point has to be sent to a neighbour - ! W neighbour and on the inner left side - IF( ii == 2 .and. (nbondi == 0 .or. nbondi == 1) ) lsend_bdy(ib_bdy,igrd,1,ir) = .true. - ! E neighbour and on the inner right side - IF( ii == jpi-1 .and. (nbondi == 0 .or. nbondi == -1) ) lsend_bdy(ib_bdy,igrd,2,ir) = .true. - ! S neighbour and on the inner down side - IF( ij == 2 .and. (nbondj == 0 .or. nbondj == 1) ) lsend_bdy(ib_bdy,igrd,3,ir) = .true. - ! N neighbour and on the inner up side - IF( ij == jpj-1 .and. (nbondj == 0 .or. nbondj == -1) ) lsend_bdy(ib_bdy,igrd,4,ir) = .true. - ! - ! check if point has to be received from a neighbour - ! W neighbour and on the outter left side - IF( ii == 1 .and. (nbondi == 0 .or. nbondi == 1) ) lrecv_bdy(ib_bdy,igrd,1,ir) = .true. - ! E neighbour and on the outter right side - IF( ii == jpi .and. (nbondi == 0 .or. nbondi == -1) ) lrecv_bdy(ib_bdy,igrd,2,ir) = .true. - ! S neighbour and on the outter down side - IF( ij == 1 .and. (nbondj == 0 .or. nbondj == 1) ) lrecv_bdy(ib_bdy,igrd,3,ir) = .true. - ! N neighbour and on the outter up side - IF( ij == jpj .and. (nbondj == 0 .or. nbondj == -1) ) lrecv_bdy(ib_bdy,igrd,4,ir) = .true. - ! - END DO - END DO ! igrd - - ! Compute rim weights for FRS scheme - ! ---------------------------------- - DO igrd = 1, jpbgrd - DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) - ir = MAX( 1, idx_bdy(ib_bdy)%nbr(ib,igrd) ) ! both rim 0 and rim 1 have the same weights - idx_bdy(ib_bdy)%nbw(ib,igrd) = 1.- TANH( REAL( ir - 1 ) *0.5 ) ! tanh formulation - ! idx_bdy(ib_bdy)%nbw(ib,igrd) = (REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic - ! idx_bdy(ib_bdy)%nbw(ib,igrd) = REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)) ! linear - END DO - END DO - - ! Compute damping coefficients - ! ---------------------------- - DO igrd = 1, jpbgrd - DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) - ir = MAX( 1, idx_bdy(ib_bdy)%nbr(ib,igrd) ) ! both rim 0 and rim 1 have the same damping coefficients - idx_bdy(ib_bdy)%nbd(ib,igrd) = 1. / ( rn_time_dmp(ib_bdy) * rday ) & - & *(REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic - idx_bdy(ib_bdy)%nbdout(ib,igrd) = 1. / ( rn_time_dmp_out(ib_bdy) * rday ) & - & *(REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic - END DO - END DO - - END DO ! ib_bdy - - ! ------------------------------------------------------ - ! Initialise masks and find normal/tangential directions - ! ------------------------------------------------------ - - ! ------------------------------------------ - ! handle rim0, do as if rim 1 was free ocean - ! ------------------------------------------ - - ztmask(:,:) = tmask(:,:,1) ; zumask(:,:) = umask(:,:,1) ; zvmask(:,:) = vmask(:,:,1) - ! For the flagu/flagv calculation below we require a version of fmask without - ! the land boundary condition (shlat) included: - DO ij = 1, jpjm1 - DO ii = 1, jpim1 - zfmask(ii,ij) = ztmask(ii,ij ) * ztmask(ii+1,ij ) & - & * ztmask(ii,ij+1) * ztmask(ii+1,ij+1) - END DO - END DO - CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) - - ! Read global 2D mask at T-points: bdytmask - ! ----------------------------------------- - ! bdytmask = 1 on the computational domain AND on open boundaries - ! = 0 elsewhere - - bdytmask(:,:) = ssmask(:,:) - - ! Derive mask on U and V grid from mask on T grid - DO ij = 1, jpjm1 - DO ii = 1, jpim1 - bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1,ij ) - bdyvmask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii ,ij+1) - END DO - END DO - CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1., bdyvmask, 'V', 1. ) ! Lateral boundary cond. - - ! bdy masks are now set to zero on rim 0 points: - DO ib_bdy = 1, nb_bdy - DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 - bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp - END DO - DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 - bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp - END DO - DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 - bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp - END DO - END DO - - CALL bdy_rim_treat( zumask, zvmask, zfmask, .true. ) ! compute flagu, flagv, ntreat on rim 0 - - ! ------------------------------------ - ! handle rim1, do as if rim 0 was land - ! ------------------------------------ - - ! z[tuv]mask are now set to zero on rim 0 points: - DO ib_bdy = 1, nb_bdy - DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 - ztmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp - END DO - DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 - zumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp - END DO - DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 - zvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp - END DO - END DO - - ! Recompute zfmask - DO ij = 1, jpjm1 - DO ii = 1, jpim1 - zfmask(ii,ij) = ztmask(ii,ij ) * ztmask(ii+1,ij ) & - & * ztmask(ii,ij+1) * ztmask(ii+1,ij+1) - END DO - END DO - CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) - - ! bdy masks are now set to zero on rim1 points: - DO ib_bdy = 1, nb_bdy - DO ib = idx_bdy(ib_bdy)%nblenrim0(1) + 1, idx_bdy(ib_bdy)%nblenrim(1) ! extent of rim 1 - bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp - END DO - DO ib = idx_bdy(ib_bdy)%nblenrim0(2) + 1, idx_bdy(ib_bdy)%nblenrim(2) ! extent of rim 1 - bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp - END DO - DO ib = idx_bdy(ib_bdy)%nblenrim0(3) + 1, idx_bdy(ib_bdy)%nblenrim(3) ! extent of rim 1 - bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp - END DO - END DO - - CALL bdy_rim_treat( zumask, zvmask, zfmask, .false. ) ! compute flagu, flagv, ntreat on rim 1 - ! - ! Check which boundaries might need communication - ALLOCATE( lsend_bdyint(nb_bdy,jpbgrd,4,0:1), lrecv_bdyint(nb_bdy,jpbgrd,4,0:1) ) - lsend_bdyint(:,:,:,:) = .false. - lrecv_bdyint(:,:,:,:) = .false. - ALLOCATE( lsend_bdyext(nb_bdy,jpbgrd,4,0:1), lrecv_bdyext(nb_bdy,jpbgrd,4,0:1) ) - lsend_bdyext(:,:,:,:) = .false. - lrecv_bdyext(:,:,:,:) = .false. - ! - DO igrd = 1, jpbgrd - DO ib_bdy = 1, nb_bdy - DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) - IF( idx_bdy(ib_bdy)%ntreat(ib,igrd) == -1 ) CYCLE - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - ir = idx_bdy(ib_bdy)%nbr(ib,igrd) - flagu = NINT(idx_bdy(ib_bdy)%flagu(ib,igrd)) - flagv = NINT(idx_bdy(ib_bdy)%flagv(ib,igrd)) - iibe = ii - flagu ! neighbouring point towards the exterior of the computational domain - ijbe = ij - flagv - iibi = ii + flagu ! neighbouring point towards the interior of the computational domain - ijbi = ij + flagv - CALL find_neib( ii, ij, idx_bdy(ib_bdy)%ntreat(ib,igrd), ii1, ij1, ii2, ij2, ii3, ij3 ) ! free ocean neighbours - ! - ! search neighbour in the west/east direction - ! Rim is on the halo and computed ocean is towards exterior of mpi domain - ! <-- (o exterior) --> - ! (1) o|x OR (2) x|o - ! |___ ___| - IF( iibi == 0 .OR. ii1 == 0 .OR. ii2 == 0 .OR. ii3 == 0 ) lrecv_bdyint(ib_bdy,igrd,1,ir) = .true. - IF( iibi == jpi+1 .OR. ii1 == jpi+1 .OR. ii2 == jpi+1 .OR. ii3 == jpi+1 ) lrecv_bdyint(ib_bdy,igrd,2,ir) = .true. - IF( iibe == 0 ) lrecv_bdyext(ib_bdy,igrd,1,ir) = .true. - IF( iibe == jpi+1 ) lrecv_bdyext(ib_bdy,igrd,2,ir) = .true. - ! Check if neighbour has its rim parallel to its mpi subdomain border and located next to its halo - ! :¨¨¨¨¨|¨¨--> | | <--¨¨|¨¨¨¨¨: - ! : | x:o | neighbour limited by ... would need o | o:x | : - ! :.....|_._:_____| (1) W neighbour E neighbour (2) |_____:_._|.....: - IF( ii == 2 .AND. ( nbondi == 1 .OR. nbondi == 0 ) .AND. & - & ( iibi == 3 .OR. ii1 == 3 .OR. ii2 == 3 .OR. ii3 == 3 ) ) lsend_bdyint(ib_bdy,igrd,1,ir)=.true. - IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. & - & ( iibi == jpi-2 .OR. ii1 == jpi-2 .OR. ii2 == jpi-2 .OR. ii3 == jpi-2) ) lsend_bdyint(ib_bdy,igrd,2,ir)=.true. - IF( ii == 2 .AND. ( nbondi == 1 .OR. nbondi == 0 ) .AND. iibe == 3 ) lsend_bdyext(ib_bdy,igrd,1,ir)=.true. - IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. iibe == jpi-2 ) lsend_bdyext(ib_bdy,igrd,2,ir)=.true. - ! - ! search neighbour in the north/south direction - ! Rim is on the halo and computed ocean is towards exterior of mpi domain - !(3) | | ^ ___o___ - ! | |___x___| OR | | x | - ! v o (4) | | - IF( ijbi == 0 .OR. ij1 == 0 .OR. ij2 == 0 .OR. ij3 == 0 ) lrecv_bdyint(ib_bdy,igrd,3,ir) = .true. - IF( ijbi == jpj+1 .OR. ij1 == jpj+1 .OR. ij2 == jpj+1 .OR. ij3 == jpj+1 ) lrecv_bdyint(ib_bdy,igrd,4,ir) = .true. - IF( ijbe == 0 ) lrecv_bdyext(ib_bdy,igrd,3,ir) = .true. - IF( ijbe == jpj+1 ) lrecv_bdyext(ib_bdy,igrd,4,ir) = .true. - ! Check if neighbour has its rim parallel to its mpi subdomain _________ border and next to its halo - ! ^ | o | : : - ! | |¨¨¨¨x¨¨¨¨| neighbour limited by ... would need o | |....x....| - ! :_________: (3) S neighbour N neighbour (4) v | o | - IF( ij == 2 .AND. ( nbondj == 1 .OR. nbondj == 0 ) .AND. & - & ( ijbi == 3 .OR. ij1 == 3 .OR. ij2 == 3 .OR. ij3 == 3 ) ) lsend_bdyint(ib_bdy,igrd,3,ir)=.true. - IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. & - & ( ijbi == jpj-2 .OR. ij1 == jpj-2 .OR. ij2 == jpj-2 .OR. ij3 == jpj-2) ) lsend_bdyint(ib_bdy,igrd,4,ir)=.true. - IF( ij == 2 .AND. ( nbondj == 1 .OR. nbondj == 0 ) .AND. ijbe == 3 ) lsend_bdyext(ib_bdy,igrd,3,ir)=.true. - IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. ijbe == jpj-2 ) lsend_bdyext(ib_bdy,igrd,4,ir)=.true. - END DO - END DO - END DO - - DO ib_bdy = 1,nb_bdy - IF( cn_dyn2d(ib_bdy) == 'orlanski' .OR. cn_dyn2d(ib_bdy) == 'orlanski_npo' .OR. & - & cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo' .OR. & - & cn_tra(ib_bdy) == 'orlanski' .OR. cn_tra(ib_bdy) == 'orlanski_npo' ) THEN - DO igrd = 1, jpbgrd - DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - IF( mig(ii) > 2 .AND. mig(ii) < jpiglo-2 .AND. mjg(ij) > 2 .AND. mjg(ij) < jpjglo-2 ) THEN - WRITE(ctmp1,*) ' Orlanski is not safe when the open boundaries are on the interior of the computational domain' - CALL ctl_stop( ctmp1 ) - END IF - END DO - END DO - END IF - END DO - ! - DEALLOCATE( nbidta, nbjdta, nbrdta ) - ! - END SUBROUTINE bdy_def - - - SUBROUTINE bdy_rim_treat( pumask, pvmask, pfmask, lrim0 ) - !!---------------------------------------------------------------------- - !! *** ROUTINE bdy_rim_treat *** - !! - !! ** Purpose : Initialize structures ( flagu, flagv, ntreat ) indicating how rim points - !! are to be handled in the boundary condition treatment - !! - !! ** Method : - to handle rim 0 zmasks must indicate ocean points (set at one on rim 0 and rim 1 and interior) - !! and bdymasks must be set at 0 on rim 0 (set at one on rim 1 and interior) - !! (as if rim 1 was free ocean) - !! - to handle rim 1 zmasks must be set at 0 on rim 0 (set at one on rim 1 and interior) - !! and bdymasks must indicate free ocean points (set at one on interior) - !! (as if rim 0 was land) - !! - we can then check in which direction the interior of the computational domain is with the difference - !! mask array values on both sides to compute flagu and flagv - !! - and look at the ocean neighbours to compute ntreat - !!---------------------------------------------------------------------- - REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pfmask ! temporary fmask excluding coastal boundary condition (shlat) - REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pumask, pvmask ! temporary t/u/v mask array - LOGICAL , INTENT (in ) :: lrim0 ! .true. -> rim 0 .false. -> rim 1 - INTEGER :: ib_bdy, ii, ij, igrd, ib, icount ! dummy loop indices - INTEGER :: i_offset, j_offset, inn ! local integer - INTEGER :: ibeg, iend ! local integer - LOGICAL :: llnon, llson, llean, llwen ! local logicals indicating the presence of a ocean neighbour - REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields - REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars - CHARACTER(LEN=1), DIMENSION(jpbgrd) :: cgrid - REAL(wp) , DIMENSION(jpi,jpj) :: ztmp - !!---------------------------------------------------------------------- - - cgrid = (/'t','u','v'/) - - DO ib_bdy = 1, nb_bdy ! Indices and directions of rim velocity components - - ! Calculate relationship of U direction to the local orientation of the boundary - ! flagu = -1 : u component is normal to the dynamical boundary and its direction is outward - ! flagu = 0 : u is tangential - ! flagu = 1 : u is normal to the boundary and is direction is inward - DO igrd = 1, jpbgrd - SELECT CASE( igrd ) - CASE( 1 ) ; zmask => pumask ; i_offset = 0 - CASE( 2 ) ; zmask => bdytmask ; i_offset = 1 - CASE( 3 ) ; zmask => pfmask ; i_offset = 0 - END SELECT - icount = 0 - ztmp(:,:) = -999._wp - IF( lrim0 ) THEN ! extent of rim 0 - ibeg = 1 ; iend = idx_bdy(ib_bdy)%nblenrim0(igrd) - ELSE ! extent of rim 1 - ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1 ; iend = idx_bdy(ib_bdy)%nblenrim(igrd) - END IF - DO ib = ibeg, iend - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE - zwfl = zmask(ii+i_offset-1,ij) - zefl = zmask(ii+i_offset ,ij) - ! This error check only works if you are using the bdyXmask arrays - IF( i_offset == 1 .and. zefl + zwfl == 2. ) THEN - icount = icount + 1 - IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) - ELSE - ztmp(ii,ij) = -zwfl + zefl - ENDIF - END DO - IF( icount /= 0 ) THEN - WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,', & - ' are not boundary points (flagu calculation). Check nbi, nbj, indices for boundary set ',ib_bdy - CALL ctl_stop( ctmp1 ) - ENDIF - SELECT CASE( igrd ) - CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. ) - CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. ) - CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. ) - END SELECT - DO ib = ibeg, iend - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - idx_bdy(ib_bdy)%flagu(ib,igrd) = ztmp(ii,ij) - END DO - END DO - - ! Calculate relationship of V direction to the local orientation of the boundary - ! flagv = -1 : v component is normal to the dynamical boundary but its direction is outward - ! flagv = 0 : v is tangential - ! flagv = 1 : v is normal to the boundary and is direction is inward - DO igrd = 1, jpbgrd - SELECT CASE( igrd ) - CASE( 1 ) ; zmask => pvmask ; j_offset = 0 - CASE( 2 ) ; zmask => pfmask ; j_offset = 0 - CASE( 3 ) ; zmask => bdytmask ; j_offset = 1 - END SELECT - icount = 0 - ztmp(:,:) = -999._wp - IF( lrim0 ) THEN ! extent of rim 0 - ibeg = 1 ; iend = idx_bdy(ib_bdy)%nblenrim0(igrd) - ELSE ! extent of rim 1 - ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1 ; iend = idx_bdy(ib_bdy)%nblenrim(igrd) - END IF - DO ib = ibeg, iend - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE - zsfl = zmask(ii,ij+j_offset-1) - znfl = zmask(ii,ij+j_offset ) - ! This error check only works if you are using the bdyXmask arrays - IF( j_offset == 1 .and. znfl + zsfl == 2. ) THEN - IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) - icount = icount + 1 - ELSE - ztmp(ii,ij) = -zsfl + znfl - END IF - END DO - IF( icount /= 0 ) THEN - WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,', & - ' are not boundary points (flagv calculation). Check nbi, nbj, indices for boundary set ',ib_bdy - CALL ctl_stop( ctmp1 ) - ENDIF - SELECT CASE( igrd ) - CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. ) - CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. ) - CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. ) - END SELECT - DO ib = ibeg, iend - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - idx_bdy(ib_bdy)%flagv(ib,igrd) = ztmp(ii,ij) - END DO - END DO - ! - END DO ! ib_bdy - - DO ib_bdy = 1, nb_bdy - DO igrd = 1, jpbgrd - SELECT CASE( igrd ) - CASE( 1 ) ; zmask => bdytmask - CASE( 2 ) ; zmask => bdyumask - CASE( 3 ) ; zmask => bdyvmask - END SELECT - ztmp(:,:) = -999._wp - IF( lrim0 ) THEN ! extent of rim 0 - ibeg = 1 ; iend = idx_bdy(ib_bdy)%nblenrim0(igrd) - ELSE ! extent of rim 1 - ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1 ; iend = idx_bdy(ib_bdy)%nblenrim(igrd) - END IF - DO ib = ibeg, iend - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE - llnon = zmask(ii ,ij+1) == 1. - llson = zmask(ii ,ij-1) == 1. - llean = zmask(ii+1,ij ) == 1. - llwen = zmask(ii-1,ij ) == 1. - inn = COUNT( (/ llnon, llson, llean, llwen /) ) - IF( inn == 0 ) THEN ! no neighbours -> interior of a corner or cluster of rim points - ! ! ! _____ ! _____ ! __ __ - ! 1 | o ! 2 o | ! 3 | x ! 4 x | ! | | -> error - ! |_x_ _ ! _ _x_| ! | o ! o | ! |x_x| - IF( zmask(ii+1,ij+1) == 1. ) THEN ; ztmp(ii,ij) = 1. - ELSEIF( zmask(ii-1,ij+1) == 1. ) THEN ; ztmp(ii,ij) = 2. - ELSEIF( zmask(ii+1,ij-1) == 1. ) THEN ; ztmp(ii,ij) = 3. - ELSEIF( zmask(ii-1,ij-1) == 1. ) THEN ; ztmp(ii,ij) = 4. - ELSE ; ztmp(ii,ij) = -1. - WRITE(ctmp1,*) 'Problem with ',cgrid(igrd) ,' grid point', ii, ij, & - ' on boundary set ', ib_bdy, ' has no free ocean neighbour' - IF( lrim0 ) THEN - WRITE(ctmp2,*) ' There seems to be a cluster of rim 0 points.' - ELSE - WRITE(ctmp2,*) ' There seems to be a cluster of rim 1 points.' - END IF - CALL ctl_warn( ctmp1, ctmp2 ) - END IF - END IF - IF( inn == 1 ) THEN ! middle of linear bdy or incomplete corner ! ___ o - ! | ! | ! o ! ______ ! |x___ - ! 5 | x o ! 6 o x | ! 7 __x__ ! 8 x - ! | ! | ! ! o - IF( llean ) ztmp(ii,ij) = 5. - IF( llwen ) ztmp(ii,ij) = 6. - IF( llnon ) ztmp(ii,ij) = 7. - IF( llson ) ztmp(ii,ij) = 8. - END IF - IF( inn == 2 ) THEN ! exterior of a corner - ! o ! o ! _____| ! |_____ - ! 9 ____x o ! 10 o x___ ! 11 x o ! 12 o x - ! | ! | ! o ! o - IF( llnon .AND. llean ) ztmp(ii,ij) = 9. - IF( llnon .AND. llwen ) ztmp(ii,ij) = 10. - IF( llson .AND. llean ) ztmp(ii,ij) = 11. - IF( llson .AND. llwen ) ztmp(ii,ij) = 12. - END IF - IF( inn == 3 ) THEN ! 3 neighbours __ __ - ! |_ o ! o _| ! |_| ! o - ! 13 _| x o ! 14 o x |_ ! 15 o x o ! 16 o x o - ! | o ! o | ! o ! __|¨|__ - IF( llnon .AND. llean .AND. llson ) ztmp(ii,ij) = 13. - IF( llnon .AND. llwen .AND. llson ) ztmp(ii,ij) = 14. - IF( llwen .AND. llson .AND. llean ) ztmp(ii,ij) = 15. - IF( llwen .AND. llnon .AND. llean ) ztmp(ii,ij) = 16. - END IF - IF( inn == 4 ) THEN - WRITE(ctmp1,*) 'Problem with ',cgrid(igrd) ,' grid point', ii, ij, & - ' on boundary set ', ib_bdy, ' have 4 neighbours' - CALL ctl_stop( ctmp1 ) - END IF - END DO - SELECT CASE( igrd ) - CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. ) - CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. ) - CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. ) - END SELECT - DO ib = ibeg, iend - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - idx_bdy(ib_bdy)%ntreat(ib,igrd) = NINT(ztmp(ii,ij)) - END DO - END DO - END DO - - END SUBROUTINE bdy_rim_treat - - - SUBROUTINE find_neib( ii, ij, itreat, ii1, ij1, ii2, ij2, ii3, ij3 ) - !!---------------------------------------------------------------------- - !! *** ROUTINE find_neib *** - !! - !! ** Purpose : get ii1, ij1, ii2, ij2, ii3, ij3, the indices of - !! the free ocean neighbours of (ii,ij) for bdy treatment - !! - !! ** Method : use itreat input to select a case - !! N.B. ntreat is defined for all bdy points in routine bdy_rim_treat - !! - !!---------------------------------------------------------------------- - INTEGER, INTENT(in ) :: ii, ij, itreat - INTEGER, INTENT( out) :: ii1, ij1, ii2, ij2, ii3, ij3 - !!---------------------------------------------------------------------- - SELECT CASE( itreat ) ! points that will be used by bdy routines, -1 will be discarded - ! ! ! _____ ! _____ - ! 1 | o ! 2 o | ! 3 | x ! 4 x | - ! |_x_ _ ! _ _x_| ! | o ! o | - CASE( 1 ) ; ii1 = ii+1 ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 - CASE( 2 ) ; ii1 = ii-1 ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 - CASE( 3 ) ; ii1 = ii+1 ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 - CASE( 4 ) ; ii1 = ii-1 ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 - ! | ! | ! o ! ______ ! or incomplete corner - ! 5 | x o ! 6 o x | ! 7 __x__ ! 8 x ! 7 ____ o - ! | ! | ! ! o ! |x___ - CASE( 5 ) ; ii1 = ii+1 ; ij1 = ij ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 - CASE( 6 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 - CASE( 7 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 - CASE( 8 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 - ! o ! o ! _____| ! |_____ - ! 9 ____x o ! 10 o x___ ! 11 x o ! 12 o x - ! | ! | ! o ! o - CASE( 9 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 - CASE( 10 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 - CASE( 11 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 - CASE( 12 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 - ! |_ o ! o _| ! ¨¨|_|¨¨ ! o - ! 13 _| x o ! 14 o x |_ ! 15 o x o ! 16 o x o - ! | o ! o | ! o ! __|¨|__ - CASE( 13 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 - CASE( 14 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 - CASE( 15 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = ii ; ij2 = ij-1 ; ii3 = ii+1 ; ij3 = ij - CASE( 16 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = ii ; ij2 = ij+1 ; ii3 = ii+1 ; ij3 = ij - END SELECT - END SUBROUTINE find_neib - - - SUBROUTINE bdy_read_seg( kb_bdy, knblendta ) - !!---------------------------------------------------------------------- - !! *** ROUTINE bdy_coords_seg *** - !! - !! ** Purpose : build bdy coordinates with segments defined in namelist - !! - !! ** Method : read namelist nambdy_index blocks - !! - !!---------------------------------------------------------------------- - INTEGER , INTENT (in ) :: kb_bdy ! bdy number - INTEGER, DIMENSION(jpbgrd), INTENT ( out) :: knblendta ! length of index arrays - !! - INTEGER :: ios ! Local integer output status for namelist read - INTEGER :: nbdyind, nbdybeg, nbdyend - CHARACTER(LEN=1) :: ctypebdy ! - - - NAMELIST/nambdy_index/ ctypebdy, nbdyind, nbdybeg, nbdyend - !!---------------------------------------------------------------------- - - ! No REWIND here because may need to read more than one nambdy_index namelist. - ! Read only namelist_cfg to avoid unseccessfull overwrite - ! keep full control of the configuration namelist - READ ( numnam_cfg, nambdy_index, IOSTAT = ios, ERR = 904 ) -904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_index in configuration namelist' ) - IF(lwm) WRITE ( numond, nambdy_index ) - - SELECT CASE ( TRIM(ctypebdy) ) - CASE( 'N' ) - IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 - nbdyind = jpjglo - 2 ! set boundary to whole side of model domain. - nbdybeg = 2 - nbdyend = jpiglo - 1 - ENDIF - nbdysegn = nbdysegn + 1 - npckgn(nbdysegn) = kb_bdy ! Save bdy package number - jpjnob(nbdysegn) = nbdyind - jpindt(nbdysegn) = nbdybeg - jpinft(nbdysegn) = nbdyend - ! - CASE( 'S' ) - IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 - nbdyind = 2 ! set boundary to whole side of model domain. - nbdybeg = 2 - nbdyend = jpiglo - 1 - ENDIF - nbdysegs = nbdysegs + 1 - npckgs(nbdysegs) = kb_bdy ! Save bdy package number - jpjsob(nbdysegs) = nbdyind - jpisdt(nbdysegs) = nbdybeg - jpisft(nbdysegs) = nbdyend - ! - CASE( 'E' ) - IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 - nbdyind = jpiglo - 2 ! set boundary to whole side of model domain. - nbdybeg = 2 - nbdyend = jpjglo - 1 - ENDIF - nbdysege = nbdysege + 1 - npckge(nbdysege) = kb_bdy ! Save bdy package number - jpieob(nbdysege) = nbdyind - jpjedt(nbdysege) = nbdybeg - jpjeft(nbdysege) = nbdyend - ! - CASE( 'W' ) - IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 - nbdyind = 2 ! set boundary to whole side of model domain. - nbdybeg = 2 - nbdyend = jpjglo - 1 - ENDIF - nbdysegw = nbdysegw + 1 - npckgw(nbdysegw) = kb_bdy ! Save bdy package number - jpiwob(nbdysegw) = nbdyind - jpjwdt(nbdysegw) = nbdybeg - jpjwft(nbdysegw) = nbdyend - ! - CASE DEFAULT ; CALL ctl_stop( 'ctypebdy must be N, S, E or W' ) - END SELECT - - ! For simplicity we assume that in case of straight bdy, arrays have the same length - ! (even if it is true that last tangential velocity points - ! are useless). This simplifies a little bit boundary data format (and agrees with format - ! used so far in obc package) - - knblendta(1:jpbgrd) = (nbdyend - nbdybeg + 1) * nn_rimwidth(kb_bdy) - - END SUBROUTINE bdy_read_seg - - - SUBROUTINE bdy_ctl_seg - !!---------------------------------------------------------------------- - !! *** ROUTINE bdy_ctl_seg *** - !! - !! ** Purpose : Check straight open boundary segments location - !! - !! ** Method : - Look for open boundary corners - !! - Check that segments start or end on land - !!---------------------------------------------------------------------- - INTEGER :: ib, ib1, ib2, ji ,jj, itest - INTEGER, DIMENSION(jp_nseg,2) :: icorne, icornw, icornn, icorns - REAL(wp), DIMENSION(2) :: ztestmask - !!---------------------------------------------------------------------- - ! - IF (lwp) WRITE(numout,*) ' ' - IF (lwp) WRITE(numout,*) 'bdy_ctl_seg: Check analytical segments' - IF (lwp) WRITE(numout,*) '~~~~~~~~~~~~' - ! - IF(lwp) WRITE(numout,*) 'Number of east segments : ', nbdysege - IF(lwp) WRITE(numout,*) 'Number of west segments : ', nbdysegw - IF(lwp) WRITE(numout,*) 'Number of north segments : ', nbdysegn - IF(lwp) WRITE(numout,*) 'Number of south segments : ', nbdysegs - ! 1. Check bounds - !---------------- - DO ib = 1, nbdysegn - IF (lwp) WRITE(numout,*) '**check north seg bounds pckg: ', npckgn(ib) - IF ((jpjnob(ib).ge.jpjglo-1).or.& - &(jpjnob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) - IF (jpindt(ib).ge.jpinft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) - IF (jpindt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) - IF (jpinft(ib).gt.jpiglo) CALL ctl_stop( 'End index out of domain' ) - END DO - ! - DO ib = 1, nbdysegs - IF (lwp) WRITE(numout,*) '**check south seg bounds pckg: ', npckgs(ib) - IF ((jpjsob(ib).ge.jpjglo-1).or.& - &(jpjsob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) - IF (jpisdt(ib).ge.jpisft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) - IF (jpisdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) - IF (jpisft(ib).gt.jpiglo) CALL ctl_stop( 'End index out of domain' ) - END DO - ! - DO ib = 1, nbdysege - IF (lwp) WRITE(numout,*) '**check east seg bounds pckg: ', npckge(ib) - IF ((jpieob(ib).ge.jpiglo-1).or.& - &(jpieob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) - IF (jpjedt(ib).ge.jpjeft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) - IF (jpjedt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) - IF (jpjeft(ib).gt.jpjglo) CALL ctl_stop( 'End index out of domain' ) - END DO - ! - DO ib = 1, nbdysegw - IF (lwp) WRITE(numout,*) '**check west seg bounds pckg: ', npckgw(ib) - IF ((jpiwob(ib).ge.jpiglo-1).or.& - &(jpiwob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) - IF (jpjwdt(ib).ge.jpjwft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) - IF (jpjwdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) - IF (jpjwft(ib).gt.jpjglo) CALL ctl_stop( 'End index out of domain' ) - ENDDO - ! - ! - ! 2. Look for segment crossings - !------------------------------ - IF (lwp) WRITE(numout,*) '**Look for segments corners :' - ! - itest = 0 ! corner number - ! - ! flag to detect if start or end of open boundary belongs to a corner - ! if not (=0), it must be on land. - ! if a corner is detected, save bdy package number for further tests - icorne(:,:)=0. ; icornw(:,:)=0. ; icornn(:,:)=0. ; icorns(:,:)=0. - ! South/West crossings - IF ((nbdysegw > 0).AND.(nbdysegs > 0)) THEN - DO ib1 = 1, nbdysegw - DO ib2 = 1, nbdysegs - IF (( jpisdt(ib2)<=jpiwob(ib1)).AND. & - & ( jpisft(ib2)>=jpiwob(ib1)).AND. & - & ( jpjwdt(ib1)<=jpjsob(ib2)).AND. & - & ( jpjwft(ib1)>=jpjsob(ib2))) THEN - IF ((jpjwdt(ib1)==jpjsob(ib2)).AND.(jpisdt(ib2)==jpiwob(ib1))) THEN - ! We have a possible South-West corner -! WRITE(numout,*) ' Found a South-West corner at (i,j): ', jpisdt(ib2), jpjwdt(ib1) -! WRITE(numout,*) ' between segments: ', npckgw(ib1), npckgs(ib2) - icornw(ib1,1) = npckgs(ib2) - icorns(ib2,1) = npckgw(ib1) - ELSEIF ((jpisft(ib2)==jpiwob(ib1)).AND.(jpjwft(ib1)==jpjsob(ib2))) THEN - WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & - & jpisft(ib2), jpjwft(ib1) - WRITE(ctmp2,*) ' Not allowed yet' - WRITE(ctmp3,*) ' Crossing problem with West segment: ',npckgw(ib1), & - & ' and South segment: ',npckgs(ib2) - CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) - ELSE - WRITE(ctmp1,*) ' Check South and West Open boundary indices' - WRITE(ctmp2,*) ' Crossing problem with West segment: ',npckgw(ib1) , & - & ' and South segment: ',npckgs(ib2) - CALL ctl_stop( ctmp1, ctmp2 ) - END IF - END IF - END DO - END DO - END IF - ! - ! South/East crossings - IF ((nbdysege > 0).AND.(nbdysegs > 0)) THEN - DO ib1 = 1, nbdysege - DO ib2 = 1, nbdysegs - IF (( jpisdt(ib2)<=jpieob(ib1)+1).AND. & - & ( jpisft(ib2)>=jpieob(ib1)+1).AND. & - & ( jpjedt(ib1)<=jpjsob(ib2) ).AND. & - & ( jpjeft(ib1)>=jpjsob(ib2) )) THEN - IF ((jpjedt(ib1)==jpjsob(ib2)).AND.(jpisft(ib2)==jpieob(ib1)+1)) THEN - ! We have a possible South-East corner -! WRITE(numout,*) ' Found a South-East corner at (i,j): ', jpisft(ib2), jpjedt(ib1) -! WRITE(numout,*) ' between segments: ', npckge(ib1), npckgs(ib2) - icorne(ib1,1) = npckgs(ib2) - icorns(ib2,2) = npckge(ib1) - ELSEIF ((jpjeft(ib1)==jpjsob(ib2)).AND.(jpisdt(ib2)==jpieob(ib1)+1)) THEN - WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & - & jpisdt(ib2), jpjeft(ib1) - WRITE(ctmp2,*) ' Not allowed yet' - WRITE(ctmp3,*) ' Crossing problem with East segment: ',npckge(ib1), & - & ' and South segment: ',npckgs(ib2) - CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) - ELSE - WRITE(ctmp1,*) ' Check South and East Open boundary indices' - WRITE(ctmp2,*) ' Crossing problem with East segment: ',npckge(ib1), & - & ' and South segment: ',npckgs(ib2) - CALL ctl_stop( ctmp1, ctmp2 ) - END IF - END IF - END DO - END DO - END IF - ! - ! North/West crossings - IF ((nbdysegn > 0).AND.(nbdysegw > 0)) THEN - DO ib1 = 1, nbdysegw - DO ib2 = 1, nbdysegn - IF (( jpindt(ib2)<=jpiwob(ib1) ).AND. & - & ( jpinft(ib2)>=jpiwob(ib1) ).AND. & - & ( jpjwdt(ib1)<=jpjnob(ib2)+1).AND. & - & ( jpjwft(ib1)>=jpjnob(ib2)+1)) THEN - IF ((jpjwft(ib1)==jpjnob(ib2)+1).AND.(jpindt(ib2)==jpiwob(ib1))) THEN - ! We have a possible North-West corner -! WRITE(numout,*) ' Found a North-West corner at (i,j): ', jpindt(ib2), jpjwft(ib1) -! WRITE(numout,*) ' between segments: ', npckgw(ib1), npckgn(ib2) - icornw(ib1,2) = npckgn(ib2) - icornn(ib2,1) = npckgw(ib1) - ELSEIF ((jpjwdt(ib1)==jpjnob(ib2)+1).AND.(jpinft(ib2)==jpiwob(ib1))) THEN - WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & - & jpinft(ib2), jpjwdt(ib1) - WRITE(ctmp2,*) ' Not allowed yet' - WRITE(ctmp3,*) ' Crossing problem with West segment: ',npckgw(ib1), & - & ' and North segment: ',npckgn(ib2) - CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) - ELSE - WRITE(ctmp1,*) ' Check North and West Open boundary indices' - WRITE(ctmp2,*) ' Crossing problem with West segment: ',npckgw(ib1), & - & ' and North segment: ',npckgn(ib2) - CALL ctl_stop( ctmp1, ctmp2 ) - END IF - END IF - END DO - END DO - END IF - ! - ! North/East crossings - IF ((nbdysegn > 0).AND.(nbdysege > 0)) THEN - DO ib1 = 1, nbdysege - DO ib2 = 1, nbdysegn - IF (( jpindt(ib2)<=jpieob(ib1)+1).AND. & - & ( jpinft(ib2)>=jpieob(ib1)+1).AND. & - & ( jpjedt(ib1)<=jpjnob(ib2)+1).AND. & - & ( jpjeft(ib1)>=jpjnob(ib2)+1)) THEN - IF ((jpjeft(ib1)==jpjnob(ib2)+1).AND.(jpinft(ib2)==jpieob(ib1)+1)) THEN - ! We have a possible North-East corner -! WRITE(numout,*) ' Found a North-East corner at (i,j): ', jpinft(ib2), jpjeft(ib1) -! WRITE(numout,*) ' between segments: ', npckge(ib1), npckgn(ib2) - icorne(ib1,2) = npckgn(ib2) - icornn(ib2,2) = npckge(ib1) - ELSEIF ((jpjedt(ib1)==jpjnob(ib2)+1).AND.(jpindt(ib2)==jpieob(ib1)+1)) THEN - WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & - & jpindt(ib2), jpjedt(ib1) - WRITE(ctmp2,*) ' Not allowed yet' - WRITE(ctmp3,*) ' Crossing problem with East segment: ',npckge(ib1), & - & ' and North segment: ',npckgn(ib2) - CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) - ELSE - WRITE(ctmp1,*) ' Check North and East Open boundary indices' - WRITE(ctmp2,*) ' Crossing problem with East segment: ',npckge(ib1), & - & ' and North segment: ',npckgn(ib2) - CALL ctl_stop( ctmp1, ctmp2 ) - END IF - END IF - END DO - END DO - END IF - ! - ! 3. Check if segment extremities are on land - !-------------------------------------------- - ! - ! West segments - DO ib = 1, nbdysegw - ! get mask at boundary extremities: - ztestmask(1:2)=0. - DO ji = 1, jpi - DO jj = 1, jpj - IF (((ji + nimpp - 1) == jpiwob(ib)).AND. & - & ((jj + njmpp - 1) == jpjwdt(ib))) ztestmask(1)=tmask(ji,jj,1) - IF (((ji + nimpp - 1) == jpiwob(ib)).AND. & - & ((jj + njmpp - 1) == jpjwft(ib))) ztestmask(2)=tmask(ji,jj,1) - END DO - END DO - CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain - - IF (ztestmask(1)==1) THEN - IF (icornw(ib,1)==0) THEN - WRITE(ctmp1,*) ' Open boundary segment ', npckgw(ib) - CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) - ELSE - ! This is a corner - IF(lwp) WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib) - CALL bdy_ctl_corn(npckgw(ib), icornw(ib,1)) - itest=itest+1 - ENDIF - ENDIF - IF (ztestmask(2)==1) THEN - IF (icornw(ib,2)==0) THEN - WRITE(ctmp1,*) ' Open boundary segment ', npckgw(ib) - CALL ctl_stop( ' ', ctmp1, ' does not end on land or on a corner' ) - ELSE - ! This is a corner - IF(lwp) WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib) - CALL bdy_ctl_corn(npckgw(ib), icornw(ib,2)) - itest=itest+1 - ENDIF - ENDIF - END DO - ! - ! East segments - DO ib = 1, nbdysege - ! get mask at boundary extremities: - ztestmask(1:2)=0. - DO ji = 1, jpi - DO jj = 1, jpj - IF (((ji + nimpp - 1) == jpieob(ib)+1).AND. & - & ((jj + njmpp - 1) == jpjedt(ib))) ztestmask(1)=tmask(ji,jj,1) - IF (((ji + nimpp - 1) == jpieob(ib)+1).AND. & - & ((jj + njmpp - 1) == jpjeft(ib))) ztestmask(2)=tmask(ji,jj,1) - END DO - END DO - CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain - - IF (ztestmask(1)==1) THEN - IF (icorne(ib,1)==0) THEN - WRITE(ctmp1,*) ' Open boundary segment ', npckge(ib) - CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) - ELSE - ! This is a corner - IF(lwp) WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib) - CALL bdy_ctl_corn(npckge(ib), icorne(ib,1)) - itest=itest+1 - ENDIF - ENDIF - IF (ztestmask(2)==1) THEN - IF (icorne(ib,2)==0) THEN - WRITE(ctmp1,*) ' Open boundary segment ', npckge(ib) - CALL ctl_stop( ctmp1, ' does not end on land or on a corner' ) - ELSE - ! This is a corner - IF(lwp) WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib) - CALL bdy_ctl_corn(npckge(ib), icorne(ib,2)) - itest=itest+1 - ENDIF - ENDIF - END DO - ! - ! South segments - DO ib = 1, nbdysegs - ! get mask at boundary extremities: - ztestmask(1:2)=0. - DO ji = 1, jpi - DO jj = 1, jpj - IF (((jj + njmpp - 1) == jpjsob(ib)).AND. & - & ((ji + nimpp - 1) == jpisdt(ib))) ztestmask(1)=tmask(ji,jj,1) - IF (((jj + njmpp - 1) == jpjsob(ib)).AND. & - & ((ji + nimpp - 1) == jpisft(ib))) ztestmask(2)=tmask(ji,jj,1) - END DO - END DO - CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain - - IF ((ztestmask(1)==1).AND.(icorns(ib,1)==0)) THEN - WRITE(ctmp1,*) ' Open boundary segment ', npckgs(ib) - CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) - ENDIF - IF ((ztestmask(2)==1).AND.(icorns(ib,2)==0)) THEN - WRITE(ctmp1,*) ' Open boundary segment ', npckgs(ib) - CALL ctl_stop( ctmp1, ' does not end on land or on a corner' ) - ENDIF - END DO - ! - ! North segments - DO ib = 1, nbdysegn - ! get mask at boundary extremities: - ztestmask(1:2)=0. - DO ji = 1, jpi - DO jj = 1, jpj - IF (((jj + njmpp - 1) == jpjnob(ib)+1).AND. & - & ((ji + nimpp - 1) == jpindt(ib))) ztestmask(1)=tmask(ji,jj,1) - IF (((jj + njmpp - 1) == jpjnob(ib)+1).AND. & - & ((ji + nimpp - 1) == jpinft(ib))) ztestmask(2)=tmask(ji,jj,1) - END DO - END DO - CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain - - IF ((ztestmask(1)==1).AND.(icornn(ib,1)==0)) THEN - WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) - CALL ctl_stop( ctmp1, ' does not start on land' ) - ENDIF - IF ((ztestmask(2)==1).AND.(icornn(ib,2)==0)) THEN - WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) - CALL ctl_stop( ctmp1, ' does not end on land' ) - ENDIF - END DO - ! - IF ((itest==0).AND.(lwp)) WRITE(numout,*) 'NO open boundary corner found' - ! - ! Other tests TBD: - ! segments completly on land - ! optimized open boundary array length according to landmask - ! Nudging layers that overlap with interior domain - ! - END SUBROUTINE bdy_ctl_seg - - - SUBROUTINE bdy_coords_seg( nbidta, nbjdta, nbrdta ) - !!---------------------------------------------------------------------- - !! *** ROUTINE bdy_coords_seg *** - !! - !! ** Purpose : build nbidta, nbidta, nbrdta for bdy built with segments - !! - !! ** Method : - !! - !!---------------------------------------------------------------------- - INTEGER, DIMENSION(:,:,:), intent( out) :: nbidta, nbjdta, nbrdta ! Index arrays: i and j indices of bdy dta - !! - INTEGER :: ii, ij, ir, iseg - INTEGER :: igrd ! grid type (t=1, u=2, v=3) - INTEGER :: icount ! - INTEGER :: ib_bdy ! bdy number - !!---------------------------------------------------------------------- - - ! East - !----- - DO iseg = 1, nbdysege - ib_bdy = npckge(iseg) - ! - ! ------------ T points ------------- - igrd=1 - icount=0 - DO ir = 1, nn_rimwidth(ib_bdy) - DO ij = jpjedt(iseg), jpjeft(iseg) - icount = icount + 1 - nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir - nbjdta(icount, igrd, ib_bdy) = ij - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - ENDDO - ! - ! ------------ U points ------------- - igrd=2 - icount=0 - DO ir = 1, nn_rimwidth(ib_bdy) - DO ij = jpjedt(iseg), jpjeft(iseg) - icount = icount + 1 - nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir - nbjdta(icount, igrd, ib_bdy) = ij - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - ENDDO - ! - ! ------------ V points ------------- - igrd=3 - icount=0 - DO ir = 1, nn_rimwidth(ib_bdy) - ! DO ij = jpjedt(iseg), jpjeft(iseg) - 1 - DO ij = jpjedt(iseg), jpjeft(iseg) - icount = icount + 1 - nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir - nbjdta(icount, igrd, ib_bdy) = ij - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point - nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point - ENDDO - ENDDO - ! - ! West - !----- - DO iseg = 1, nbdysegw - ib_bdy = npckgw(iseg) - ! - ! ------------ T points ------------- - igrd=1 - icount=0 - DO ir = 1, nn_rimwidth(ib_bdy) - DO ij = jpjwdt(iseg), jpjwft(iseg) - icount = icount + 1 - nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 - nbjdta(icount, igrd, ib_bdy) = ij - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - ENDDO - ! - ! ------------ U points ------------- - igrd=2 - icount=0 - DO ir = 1, nn_rimwidth(ib_bdy) - DO ij = jpjwdt(iseg), jpjwft(iseg) - icount = icount + 1 - nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 - nbjdta(icount, igrd, ib_bdy) = ij - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - ENDDO - ! - ! ------------ V points ------------- - igrd=3 - icount=0 - DO ir = 1, nn_rimwidth(ib_bdy) - ! DO ij = jpjwdt(iseg), jpjwft(iseg) - 1 - DO ij = jpjwdt(iseg), jpjwft(iseg) - icount = icount + 1 - nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 - nbjdta(icount, igrd, ib_bdy) = ij - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point - nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point - ENDDO - ENDDO - ! - ! North - !----- - DO iseg = 1, nbdysegn - ib_bdy = npckgn(iseg) - ! - ! ------------ T points ------------- - igrd=1 - icount=0 - DO ir = 1, nn_rimwidth(ib_bdy) - DO ii = jpindt(iseg), jpinft(iseg) - icount = icount + 1 - nbidta(icount, igrd, ib_bdy) = ii - nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - ENDDO - ! - ! ------------ U points ------------- - igrd=2 - icount=0 - DO ir = 1, nn_rimwidth(ib_bdy) - ! DO ii = jpindt(iseg), jpinft(iseg) - 1 - DO ii = jpindt(iseg), jpinft(iseg) - icount = icount + 1 - nbidta(icount, igrd, ib_bdy) = ii - nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point - nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point - ENDDO - ! - ! ------------ V points ------------- - igrd=3 - icount=0 - DO ir = 1, nn_rimwidth(ib_bdy) - DO ii = jpindt(iseg), jpinft(iseg) - icount = icount + 1 - nbidta(icount, igrd, ib_bdy) = ii - nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - ENDDO - ENDDO - ! - ! South - !----- - DO iseg = 1, nbdysegs - ib_bdy = npckgs(iseg) - ! - ! ------------ T points ------------- - igrd=1 - icount=0 - DO ir = 1, nn_rimwidth(ib_bdy) - DO ii = jpisdt(iseg), jpisft(iseg) - icount = icount + 1 - nbidta(icount, igrd, ib_bdy) = ii - nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - ENDDO - ! - ! ------------ U points ------------- - igrd=2 - icount=0 - DO ir = 1, nn_rimwidth(ib_bdy) - ! DO ii = jpisdt(iseg), jpisft(iseg) - 1 - DO ii = jpisdt(iseg), jpisft(iseg) - icount = icount + 1 - nbidta(icount, igrd, ib_bdy) = ii - nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point - nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point - ENDDO - ! - ! ------------ V points ------------- - igrd=3 - icount=0 - DO ir = 1, nn_rimwidth(ib_bdy) - DO ii = jpisdt(iseg), jpisft(iseg) - icount = icount + 1 - nbidta(icount, igrd, ib_bdy) = ii - nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - ENDDO - ENDDO - - - END SUBROUTINE bdy_coords_seg - - - SUBROUTINE bdy_ctl_corn( ib1, ib2 ) - !!---------------------------------------------------------------------- - !! *** ROUTINE bdy_ctl_corn *** - !! - !! ** Purpose : Check numerical schemes consistency between - !! segments having a common corner - !! - !! ** Method : - !!---------------------------------------------------------------------- - INTEGER, INTENT(in) :: ib1, ib2 - INTEGER :: itest - !!---------------------------------------------------------------------- - itest = 0 - - IF( cn_dyn2d(ib1) /= cn_dyn2d(ib2) ) itest = itest + 1 - IF( cn_dyn3d(ib1) /= cn_dyn3d(ib2) ) itest = itest + 1 - IF( cn_tra (ib1) /= cn_tra (ib2) ) itest = itest + 1 - ! - IF( nn_dyn2d_dta(ib1) /= nn_dyn2d_dta(ib2) ) itest = itest + 1 - IF( nn_dyn3d_dta(ib1) /= nn_dyn3d_dta(ib2) ) itest = itest + 1 - IF( nn_tra_dta (ib1) /= nn_tra_dta (ib2) ) itest = itest + 1 - ! - IF( nn_rimwidth(ib1) /= nn_rimwidth(ib2) ) itest = itest + 1 - ! - IF( itest>0 ) THEN - WRITE(ctmp1,*) ' Segments ', ib1, 'and ', ib2 - CALL ctl_stop( ctmp1, ' have different open bdy schemes' ) - ENDIF - ! - END SUBROUTINE bdy_ctl_corn - - - SUBROUTINE bdy_meshwri() - !!---------------------------------------------------------------------- - !! *** ROUTINE bdy_meshwri *** - !! - !! ** Purpose : write netcdf file with nbr, flagu, flagv, ntreat for T, U - !! and V points in 2D arrays for easier visualisation/control - !! - !! ** Method : use iom_rstput as in domwri.F - !!---------------------------------------------------------------------- - INTEGER :: ib_bdy, ii, ij, igrd, ib ! dummy loop indices - INTEGER :: inum ! - - - REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields - REAL(wp) , DIMENSION(jpi,jpj) :: ztmp - CHARACTER(LEN=1) , DIMENSION(jpbgrd) :: cgrid - !!---------------------------------------------------------------------- - cgrid = (/'t','u','v'/) - CALL iom_open( 'bdy_mesh', inum, ldwrt = .TRUE. ) - DO igrd = 1, jpbgrd - SELECT CASE( igrd ) - CASE( 1 ) ; zmask => tmask(:,:,1) - CASE( 2 ) ; zmask => umask(:,:,1) - CASE( 3 ) ; zmask => vmask(:,:,1) - END SELECT - ztmp(:,:) = zmask(:,:) - DO ib_bdy = 1, nb_bdy - DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) ! nbr deined for all rims - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%nbr(ib,igrd), wp) + 10. - IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) - END DO - END DO - CALL iom_rstput( 0, 0, inum, 'bdy_nbr_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) - ztmp(:,:) = zmask(:,:) - DO ib_bdy = 1, nb_bdy - DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! flagu defined only for rims 0 and 1 - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagu(ib,igrd), wp) + 10. - IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) - END DO - END DO - CALL iom_rstput( 0, 0, inum, 'flagu_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) - ztmp(:,:) = zmask(:,:) - DO ib_bdy = 1, nb_bdy - DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! flagv defined only for rims 0 and 1 - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagv(ib,igrd), wp) + 10. - IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) - END DO - END DO - CALL iom_rstput( 0, 0, inum, 'flagv_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) - ztmp(:,:) = zmask(:,:) - DO ib_bdy = 1, nb_bdy - DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! ntreat defined only for rims 0 and 1 - ii = idx_bdy(ib_bdy)%nbi(ib,igrd) - ij = idx_bdy(ib_bdy)%nbj(ib,igrd) - ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%ntreat(ib,igrd), wp) + 10. - IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) - END DO - END DO - CALL iom_rstput( 0, 0, inum, 'ntreat_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) - END DO - CALL iom_close( inum ) - - END SUBROUTINE bdy_meshwri - - !!================================================================================= -END MODULE bdyini diff --git a/MY_SRC/domain.F90 b/MY_SRC/domain.F90 index 1328b8b..b281831 100755 --- a/MY_SRC/domain.F90 +++ b/MY_SRC/domain.F90 @@ -5,20 +5,20 @@ MODULE domain !!============================================================================== !! History : OPA ! 1990-10 (C. Levy - G. Madec) Original code !! ! 1992-01 (M. Imbard) insert time step initialization - !! ! 1996-06 (G. Madec) generalized vertical coordinate + !! ! 1996-06 (G. Madec) generalized vertical coordinate !! ! 1997-02 (G. Madec) creation of domwri.F !! ! 2001-05 (E.Durand - G. Madec) insert closed sea !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module !! 2.0 ! 2005-11 (V. Garnier) Surface pressure gradient organization - !! 3.3 ! 2010-11 (G. Madec) initialisation in C1D configuration + !! 3.3 ! 2010-11 (G. Madec) initialisation in C1D configuration !! 3.6 ! 2013 ( J. Simeon, C. Calone, G. Madec, C. Ethe ) Online coarsening of outputs !! 3.7 ! 2015-11 (G. Madec, A. Coward) time varying zgr by default !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface + !! 4.1 ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio !!---------------------------------------------------------------------- - + !!---------------------------------------------------------------------- !! dom_init : initialize the space and time domain - !! dom_glo : initialize global domain <--> local domain indices !! dom_nam : read and contral domain namelists !! dom_ctl : control print for the ocean domain !! domain_cfg : read the global domain size in domain configuration file @@ -26,23 +26,33 @@ MODULE domain !!---------------------------------------------------------------------- USE oce ! ocean variables USE dom_oce ! domain: ocean + USE domtile ! tiling utilities +#if defined key_qco + USE domqco ! quasi-eulerian coord. +#elif defined key_linssh + ! ! fix in time coord. +#else + USE domvvl ! variable volume coord. +#endif +#if defined key_agrif + USE agrif_oce_interp, ONLY : Agrif_istate_ssh ! ssh interpolated from parent +#endif USE sbc_oce ! surface boundary condition: ocean USE trc_oce ! shared ocean & passive tracers variab USE phycst ! physical constants - USE closea ! closed seas USE domhgr ! domain: set the horizontal mesh USE domzgr ! domain: set the vertical mesh USE dommsk ! domain: set the mask system USE domwri ! domain: write the meshmask file - USE domvvl ! variable volume - USE c1d ! 1D configuration - USE dyncor_c1d ! 1D configuration: Coriolis term (cor_c1d routine) - USE wet_dry, ONLY : ll_wd + USE wet_dry , ONLY : ll_wd ! wet & drying flag + USE closea , ONLY : dom_clo ! closed seas routine + USE c1d ! USE in_out_manager ! I/O manager USE iom ! I/O library USE lbclnk ! ocean lateral boundary condition (or mpp link) USE lib_mpp ! distributed memory computing library + USE restart ! only for lrst_oce and rst_read_ssh IMPLICIT NONE PRIVATE @@ -50,19 +60,21 @@ MODULE domain PUBLIC dom_init ! called by nemogcm.F90 PUBLIC domain_cfg ! called by nemogcm.F90 + !! * Substitutions +# include "do_loop_substitute.h90" !!------------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: domain.F90 13436 2020-08-25 15:11:29Z acc $ + !! $Id: domain.F90 14547 2021-02-25 17:07:15Z techene $ !! Software governed by the CeCILL license (see ./LICENSE) !!------------------------------------------------------------------------- CONTAINS - SUBROUTINE dom_init(cdstr) + SUBROUTINE dom_init( Kbb, Kmm, Kaa ) !!---------------------------------------------------------------------- !! *** ROUTINE dom_init *** - !! - !! ** Purpose : Domain initialization. Call the routines that are - !! required to create the arrays which define the space + !! + !! ** Purpose : Domain initialization. Call the routines that are + !! required to create the arrays which define the space !! and time domain of the ocean model. !! !! ** Method : - dom_msk: compute the masks from the bathymetry file @@ -72,10 +84,11 @@ SUBROUTINE dom_init(cdstr) !! - dom_wri: create the meshmask file (ln_meshmask=T) !! - 1D configuration, move Coriolis, u and v at T-point !!---------------------------------------------------------------------- - INTEGER :: ji, jj, jk, ik ! dummy loop indices + INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + ! + INTEGER :: ji, jj, jk, jt ! dummy loop indices INTEGER :: iconf = 0 ! local integers - CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))" - CHARACTER (len=*), INTENT(IN) :: cdstr ! model: NEMO or SAS. Determines core restart variables + CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))" INTEGER , DIMENSION(jpi,jpj) :: ik_top , ik_bot ! top and bottom ocean level REAL(wp), DIMENSION(jpi,jpj) :: z1_hu_0, z1_hv_0 !!---------------------------------------------------------------------- @@ -96,204 +109,163 @@ SUBROUTINE dom_init(cdstr) WRITE(numout,*) ' jpni : ', jpni, ' nn_hls : ', nn_hls WRITE(numout,*) ' jpnj : ', jpnj, ' nn_hls : ', nn_hls WRITE(numout,*) ' jpnij : ', jpnij - WRITE(numout,*) ' lateral boundary of the Global domain : jperio = ', jperio - SELECT CASE ( jperio ) - CASE( 0 ) ; WRITE(numout,*) ' (i.e. closed)' - CASE( 1 ) ; WRITE(numout,*) ' (i.e. cyclic east-west)' - CASE( 2 ) ; WRITE(numout,*) ' (i.e. cyclic north-south)' - CASE( 3 ) ; WRITE(numout,*) ' (i.e. north fold with T-point pivot)' - CASE( 4 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north fold with T-point pivot)' - CASE( 5 ) ; WRITE(numout,*) ' (i.e. north fold with F-point pivot)' - CASE( 6 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north fold with F-point pivot)' - CASE( 7 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north-south)' - CASE DEFAULT - CALL ctl_stop( 'jperio is out of range' ) - END SELECT + WRITE(numout,*) ' lateral boundary of the Global domain:' + WRITE(numout,*) ' cyclic east-west :', l_Iperio + WRITE(numout,*) ' cyclic north-south :', l_Jperio + WRITE(numout,*) ' North Pole folding :', l_NFold + WRITE(numout,*) ' type of North pole Folding:', c_NFtype WRITE(numout,*) ' Ocean model configuration used:' - WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg + WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg ENDIF - nn_wxios = 0 - ln_xios_read = .FALSE. + ! ! !== Reference coordinate system ==! ! - CALL dom_glo ! global domain versus local domain - CALL dom_nam ! read namelist ( namrun, namdom ) - ! - IF( lwxios ) THEN -!define names for restart write and set core output (restart.F90) - CALL iom_set_rst_vars(rst_wfields) - CALL iom_set_rstw_core(cdstr) - ENDIF -!reset namelist for SAS - IF(cdstr == 'SAS') THEN - IF(lrxios) THEN - IF(lwp) write(numout,*) 'Disable reading restart file using XIOS for SAS' - lrxios = .FALSE. - ENDIF - ENDIF - ! - CALL dom_hgr ! Horizontal mesh - CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry - CALL dom_msk( ik_top, ik_bot ) ! Masks - IF( ln_closea ) CALL dom_clo ! ln_closea=T : closed seas included in the simulation - ! Read in masks to define closed seas and lakes + CALL dom_nam ! read namelist ( namrun, namdom ) + CALL dom_tile_init ! Tile domain + + IF( ln_c1d ) CALL c1d_init ! 1D column configuration ! - DO jj = 1, jpj ! depth of the iceshelves - DO ji = 1, jpi - ik = mikt(ji,jj) - risfdep(ji,jj) = gdepw_0(ji,jj,ik) - END DO - END DO + CALL dom_hgr ! Horizontal mesh + + IF( ln_closea ) CALL dom_clo ! Read in masks to define closed seas and lakes + + CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry (return top and bottom ocean t-level indices) + + CALL dom_msk( ik_top, ik_bot ) ! Masks ! ht_0(:,:) = 0._wp ! Reference ocean thickness hu_0(:,:) = 0._wp hv_0(:,:) = 0._wp - DO jk = 1, jpk + hf_0(:,:) = 0._wp + DO jk = 1, jpkm1 ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk) hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk) END DO ! - ! !== time varying part of coordinate system ==! - ! - IF( ln_linssh ) THEN != Fix in time : set to the reference one for all - ! - ! before ! now ! after ! - gdept_b = gdept_0 ; gdept_n = gdept_0 ! --- ! depth of grid-points - gdepw_b = gdepw_0 ; gdepw_n = gdepw_0 ! --- ! - gde3w_n = gde3w_0 ! --- ! - ! - e3t_b = e3t_0 ; e3t_n = e3t_0 ; e3t_a = e3t_0 ! scale factors - e3u_b = e3u_0 ; e3u_n = e3u_0 ; e3u_a = e3u_0 ! - e3v_b = e3v_0 ; e3v_n = e3v_0 ; e3v_a = e3v_0 ! - e3f_n = e3f_0 ! --- ! - e3w_b = e3w_0 ; e3w_n = e3w_0 ! --- ! - e3uw_b = e3uw_0 ; e3uw_n = e3uw_0 ! --- ! - e3vw_b = e3vw_0 ; e3vw_n = e3vw_0 ! --- ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + hf_0(ji,jj) = hf_0(ji,jj) + e3f_0(ji,jj,jk)*vmask(ji,jj,jk)*vmask(ji+1,jj,jk) + END_3D + CALL lbc_lnk('domain', hf_0, 'F', 1._wp) + ! + IF( lk_SWE ) THEN ! SWE case redefine hf_0 + hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,1) * ssfmask(:,:) + ENDIF + ! + r1_ht_0(:,:) = ssmask (:,:) / ( ht_0(:,:) + 1._wp - ssmask (:,:) ) + r1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) ) + r1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) ) + r1_hf_0(:,:) = ssfmask(:,:) / ( hf_0(:,:) + 1._wp - ssfmask(:,:) ) + ! + IF( ll_wd ) THEN ! wet and drying (check ht_0 >= 0) + DO_2D( 1, 1, 1, 1 ) + IF( ht_0(ji,jj) < 0._wp .AND. ssmask(ji,jj) == 1._wp ) THEN + CALL ctl_stop( 'dom_init : ht_0 must be positive at potentially wet points' ) + ENDIF + END_2D + ENDIF + ! + ! !== initialisation of time varying coordinate ==! + ! + ! != ssh initialization + ! + IF( l_SAS ) THEN !* No ocean dynamics calculation : set to 0 + ssh(:,:,:) = 0._wp +#if defined key_agrif + ELSEIF( .NOT.Agrif_root() .AND. & + & ln_init_chfrpar ) THEN !* Interpolate initial ssh from parent + CALL Agrif_istate_ssh( Kbb, Kmm, Kaa ) +#endif + ELSE !* Read in restart file or set by user + CALL rst_read_ssh( Kbb, Kmm, Kaa ) + ENDIF + ! +#if defined key_qco + ! != Quasi-Euerian coordinate case + ! + IF( .NOT.l_offline ) CALL dom_qco_init( Kbb, Kmm, Kaa ) +#elif defined key_linssh + ! != Fix in time : key_linssh case, set through domzgr_substitute.h90 +#else + ! + IF( ln_linssh ) THEN != Fix in time : set to the reference one for all ! - z1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) ) ! _i mask due to ISF - z1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) ) + DO jt = 1, jpt ! depth of t- and w-grid-points + gdept(:,:,:,jt) = gdept_0(:,:,:) + gdepw(:,:,:,jt) = gdepw_0(:,:,:) + END DO + gde3w(:,:,:) = gde3w_0(:,:,:) ! = gdept as the sum of e3t ! - ! before ! now ! after ! - ht_n = ht_0 ! ! water column thickness - hu_b = hu_0 ; hu_n = hu_0 ; hu_a = hu_0 ! - hv_b = hv_0 ; hv_n = hv_0 ; hv_a = hv_0 ! - r1_hu_b = z1_hu_0 ; r1_hu_n = z1_hu_0 ; r1_hu_a = z1_hu_0 ! inverse of water column thickness - r1_hv_b = z1_hv_0 ; r1_hv_n = z1_hv_0 ; r1_hv_a = z1_hv_0 ! + DO jt = 1, jpt ! vertical scale factors + e3t (:,:,:,jt) = e3t_0(:,:,:) + e3u (:,:,:,jt) = e3u_0(:,:,:) + e3v (:,:,:,jt) = e3v_0(:,:,:) + e3w (:,:,:,jt) = e3w_0(:,:,:) + e3uw(:,:,:,jt) = e3uw_0(:,:,:) + e3vw(:,:,:,jt) = e3vw_0(:,:,:) + END DO + e3f (:,:,:) = e3f_0(:,:,:) ! + DO jt = 1, jpt ! water column thickness and its inverse + hu(:,:,jt) = hu_0(:,:) + hv(:,:,jt) = hv_0(:,:) + r1_hu(:,:,jt) = r1_hu_0(:,:) + r1_hv(:,:,jt) = r1_hv_0(:,:) + END DO + ht (:,:) = ht_0(:,:) ! - ELSE != time varying : initialize before/now/after variables + ELSE != Time varying : initialize before/now/after variables ! - IF( .NOT.l_offline ) CALL dom_vvl_init + IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa ) ! ENDIF +#endif + ! - IF( lk_c1d ) CALL cor_c1d ! 1D configuration: Coriolis set at T-point - ! - IF( ln_meshmask .AND. .NOT.ln_iscpl ) CALL dom_wri ! Create a domain file - IF( ln_meshmask .AND. ln_iscpl .AND. .NOT.ln_rstart ) CALL dom_wri ! Create a domain file - IF( .NOT.ln_rstart ) CALL dom_ctl ! Domain control + +#if defined key_agrif + IF( .NOT. Agrif_Root() ) CALL Agrif_Init_Domain( Kbb, Kmm, Kaa ) +#endif + IF( ln_meshmask ) CALL dom_wri ! Create a domain file + IF( .NOT.ln_rstart ) CALL dom_ctl ! Domain control ! - IF( ln_write_cfg ) CALL cfg_write ! create the configuration file + IF( ln_write_cfg ) CALL cfg_write ! create the configuration file ! IF(lwp) THEN WRITE(numout,*) WRITE(numout,*) 'dom_init : ==>>> END of domain initialization' WRITE(numout,*) '~~~~~~~~' - WRITE(numout,*) - ENDIF - ! - END SUBROUTINE dom_init - - - SUBROUTINE dom_glo - !!---------------------------------------------------------------------- - !! *** ROUTINE dom_glo *** - !! - !! ** Purpose : initialization of global domain <--> local domain indices - !! - !! ** Method : - !! - !! ** Action : - mig , mjg : local domain indices ==> global domain indices - !! - mi0 , mi1 : global domain indices ==> local domain indices - !! - mj0,, mj1 (global point not in the local domain ==> mi0>mi1 and/or mj0>mj1) - !!---------------------------------------------------------------------- - INTEGER :: ji, jj ! dummy loop argument - !!---------------------------------------------------------------------- - ! - DO ji = 1, jpi ! local domain indices ==> global domain indices - mig(ji) = ji + nimpp - 1 - END DO - DO jj = 1, jpj - mjg(jj) = jj + njmpp - 1 - END DO - ! ! global domain indices ==> local domain indices - ! ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the - ! ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. - DO ji = 1, jpiglo - mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) ) - mi1(ji) = MAX( 0 , MIN( ji - nimpp + 1, jpi ) ) - END DO - DO jj = 1, jpjglo - mj0(jj) = MAX( 1 , MIN( jj - njmpp + 1, jpj+1 ) ) - mj1(jj) = MAX( 0 , MIN( jj - njmpp + 1, jpj ) ) - END DO - IF(lwp) THEN ! control print - WRITE(numout,*) - WRITE(numout,*) 'dom_glo : domain: global <<==>> local ' - WRITE(numout,*) '~~~~~~~ ' - WRITE(numout,*) ' global domain: jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpkglo = ', jpkglo - WRITE(numout,*) ' local domain: jpi = ', jpi , ' jpj = ', jpj , ' jpk = ', jpk WRITE(numout,*) - WRITE(numout,*) ' conversion from local to global domain indices (and vise versa) done' - IF( nn_print >= 1 ) THEN - WRITE(numout,*) - WRITE(numout,*) ' conversion local ==> global i-index domain (mig)' - WRITE(numout,25) (mig(ji),ji = 1,jpi) - WRITE(numout,*) - WRITE(numout,*) ' conversion global ==> local i-index domain' - WRITE(numout,*) ' starting index (mi0)' - WRITE(numout,25) (mi0(ji),ji = 1,jpiglo) - WRITE(numout,*) ' ending index (mi1)' - WRITE(numout,25) (mi1(ji),ji = 1,jpiglo) - WRITE(numout,*) - WRITE(numout,*) ' conversion local ==> global j-index domain (mjg)' - WRITE(numout,25) (mjg(jj),jj = 1,jpj) - WRITE(numout,*) - WRITE(numout,*) ' conversion global ==> local j-index domain' - WRITE(numout,*) ' starting index (mj0)' - WRITE(numout,25) (mj0(jj),jj = 1,jpjglo) - WRITE(numout,*) ' ending index (mj1)' - WRITE(numout,25) (mj1(jj),jj = 1,jpjglo) - ENDIF ENDIF - 25 FORMAT( 100(10x,19i4,/) ) ! - END SUBROUTINE dom_glo + END SUBROUTINE dom_init SUBROUTINE dom_nam !!---------------------------------------------------------------------- !! *** ROUTINE dom_nam *** - !! + !! !! ** Purpose : read domaine namelists and print the variables. !! !! ** input : - namrun namelist !! - namdom namelist + !! - namtile namelist !! - namnc4 namelist ! "key_netcdf4" only !!---------------------------------------------------------------------- USE ioipsl !! - INTEGER :: ios ! Local integer + INTEGER :: ios ! Local integer + REAL(wp):: zrdt + !!---------------------------------------------------------------------- ! NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list, & - & nn_no , cn_exp , cn_ocerst_in, cn_ocerst_out, ln_rstart , ln_reset_ts, & - & nn_rstctl , & + & nn_no , cn_exp , cn_ocerst_in, cn_ocerst_out, ln_rstart , ln_reset_ts, nn_rstctl , & & nn_it000, nn_itend , nn_date0 , nn_time0 , nn_leapy , nn_istate , & - & nn_stock, nn_write , ln_mskland , ln_clobber , nn_chunksz, nn_euler , & - & ln_cfmeta, ln_iscpl, ln_xios_read, nn_wxios - NAMELIST/namdom/ ln_linssh, rn_isfhmin, rn_rdt, rn_atfp, ln_crs, ln_meshmask + & nn_stock, nn_write , ln_mskland , ln_clobber , nn_chunksz, ln_1st_euler , & + & ln_cfmeta, ln_xios_read, nn_wxios + NAMELIST/namdom/ ln_linssh, rn_Dt, rn_atfp, ln_crs, ln_c1d, ln_meshmask + NAMELIST/namtile/ ln_tile, nn_ltile_i, nn_ltile_j #if defined key_netcdf4 NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip #endif @@ -305,14 +277,88 @@ SUBROUTINE dom_nam WRITE(numout,*) '~~~~~~~ ' ENDIF ! + ! !=======================! + ! !== namelist namdom ==! + ! !=======================! + ! + READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' ) + READ ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' ) + IF(lwm) WRITE( numond, namdom ) + ! +#if defined key_linssh + ln_linssh = lk_linssh ! overwrite ln_linssh with the logical associated with key_linssh +#endif + ! +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN ! AGRIF child, subdivide the Parent timestep + rn_Dt = Agrif_Parent (rn_Dt ) / Agrif_Rhot() + ENDIF +#endif + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist : namdom --- space & time domain' + WRITE(numout,*) ' linear free surface (=T) ln_linssh = ', ln_linssh + WRITE(numout,*) ' create mesh/mask file ln_meshmask = ', ln_meshmask + WRITE(numout,*) ' ocean time step rn_Dt = ', rn_Dt + WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp + WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs + WRITE(numout,*) ' single column domain (1x1pt) ln_c1d = ', ln_c1d + ENDIF + ! + ! set current model timestep rDt = 2*rn_Dt if MLF or rDt = rn_Dt if RK3 +#if defined key_RK3 + rDt = rn_Dt + r1_Dt = 1._wp / rDt + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ===>>> Runge Kutta 3rd order (RK3) : rDt = ', rDt + WRITE(numout,*) + ENDIF + ! +#else + rDt = 2._wp * rn_Dt + r1_Dt = 1._wp / rDt + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ===>>> Modified Leap-Frog (MLF) : rDt = ', rDt + WRITE(numout,*) + ENDIF + ! +#endif + ! + IF( l_SAS .AND. .NOT.ln_linssh ) THEN + CALL ctl_warn( 'SAS requires linear ssh : force ln_linssh = T' ) + ln_linssh = .TRUE. + ENDIF + ! +#if defined key_qco + IF( ln_linssh ) CALL ctl_stop( 'STOP','domain: key_qco and ln_linssh=T or key_linssh are incompatible' ) +#endif + ! + ! !=======================! + ! !== namelist namrun ==! + ! !=======================! ! - REWIND( numnam_ref ) ! Namelist namrun in reference namelist : Parameters of the run READ ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist' ) - REWIND( numnam_cfg ) ! Namelist namrun in configuration namelist : Parameters of the run READ ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 ) 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist' ) IF(lwm) WRITE ( numond, namrun ) + +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN + nn_it000 = (Agrif_Parent(nn_it000)-1)*Agrif_IRhot() + 1 + nn_itend = Agrif_Parent(nn_itend) *Agrif_IRhot() + nn_date0 = Agrif_Parent(nn_date0) + nn_time0 = Agrif_Parent(nn_time0) + nn_leapy = Agrif_Parent(nn_leapy) + ENDIF +#endif ! IF(lwp) THEN ! control print WRITE(numout,*) ' Namelist : namrun --- run parameters' @@ -324,7 +370,7 @@ SUBROUTINE dom_nam WRITE(numout,*) ' restart output directory cn_ocerst_outdir= ', TRIM( cn_ocerst_outdir ) WRITE(numout,*) ' restart logical ln_rstart = ', ln_rstart WRITE(numout,*) ' reset TS from inital TS file ln_reset_ts = ', ln_reset_ts - WRITE(numout,*) ' start with forward time step nn_euler = ', nn_euler + WRITE(numout,*) ' start with forward time step ln_1st_euler = ', ln_1st_euler WRITE(numout,*) ' control of time step nn_rstctl = ', nn_rstctl WRITE(numout,*) ' number of the first time step nn_it000 = ', nn_it000 WRITE(numout,*) ' number of the last time step nn_itend = ', nn_itend @@ -337,14 +383,13 @@ SUBROUTINE dom_nam ELSE WRITE(numout,*) ' frequency of restart file nn_stock = ', nn_stock ENDIF -#if ! defined key_iomput +#if ! defined key_xios WRITE(numout,*) ' frequency of output file nn_write = ', nn_write #endif WRITE(numout,*) ' mask land points ln_mskland = ', ln_mskland WRITE(numout,*) ' additional CF standard metadata ln_cfmeta = ', ln_cfmeta WRITE(numout,*) ' overwrite an existing file ln_clobber = ', ln_clobber WRITE(numout,*) ' NetCDF chunksize (bytes) nn_chunksz = ', nn_chunksz - WRITE(numout,*) ' IS coupling at the restart step ln_iscpl = ', ln_iscpl IF( TRIM(Agrif_CFixed()) == '0' ) THEN WRITE(numout,*) ' READ restart for a single file using XIOS ln_xios_read =', ln_xios_read WRITE(numout,*) ' Write restart using XIOS nn_wxios = ', nn_wxios @@ -361,15 +406,63 @@ SUBROUTINE dom_nam ndate0 = nn_date0 nleapy = nn_leapy ninist = nn_istate - neuler = nn_euler - IF( neuler == 1 .AND. .NOT. ln_rstart ) THEN - IF(lwp) WRITE(numout,*) + ! + ! !== Set parameters for restart reading using xIOS ==! + ! + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + lrxios = ln_xios_read .AND. ln_rstart + IF( nn_wxios > 0 ) lwxios = .TRUE. !* set output file type for XIOS based on NEMO namelist + nxioso = nn_wxios + ENDIF + ! +#if defined key_RK3 + ! !== RK3: Open the restart file ==! + IF( ln_rstart ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' open the restart file' + CALL rst_read_open + ENDIF +#else + ! !== MLF: Check consistency between ln_rstart and ln_1st_euler ==! (i.e. set l_1st_euler) + l_1st_euler = ln_1st_euler + ! + IF( ln_rstart ) THEN !* Restart case + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' open the restart file' + CALL rst_read_open !- Open the restart file + ! + IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 ) THEN !- Check time-step consistency and force Euler restart if changed + CALL iom_get( numror, 'rdt', zrdt ) + IF( zrdt /= rn_Dt ) THEN + IF(lwp) WRITE( numout,*) + IF(lwp) WRITE( numout,*) ' rn_Dt = ', rn_Dt,' not equal to the READ one rdt = ', zrdt + IF(lwp) WRITE( numout,*) + IF(lwp) WRITE( numout,*) ' ==>>> forced euler first time-step' + l_1st_euler = .TRUE. + ENDIF + ENDIF + ! + IF( .NOT.l_SAS .AND. iom_varid( numror, 'sshb', ldstop = .FALSE. ) <= 0 ) THEN !- Check absence of one of the Kbb field (here sshb) + ! ! (any Kbb field is missing ==> all Kbb fields are missing) + IF( .NOT.l_1st_euler ) THEN + CALL ctl_warn('dom_nam : ssh at Kbb not found in restart files ', & + & 'l_1st_euler forced to .true. and ' , & + & 'ssh(Kbb) = ssh(Kmm) ' ) + l_1st_euler = .TRUE. + ENDIF + ENDIF + ELSEIF( .NOT.l_1st_euler ) THEN !* Initialization case + IF(lwp) WRITE(numout,*) IF(lwp) WRITE(numout,*)' ==>>> Start from rest (ln_rstart=F)' - IF(lwp) WRITE(numout,*)' an Euler initial time step is used : nn_euler is forced to 0 ' - neuler = 0 + IF(lwp) WRITE(numout,*)' an Euler initial time step is used : l_1st_euler is forced to .true. ' + l_1st_euler = .TRUE. ENDIF - ! ! control of output frequency - IF( .NOT. ln_rst_list ) THEN ! we use nn_stock +#endif + ! + ! !== control of output frequency ==! + ! + IF( .NOT. ln_rst_list ) THEN ! we use nn_stock IF( nn_stock == -1 ) CALL ctl_warn( 'nn_stock = -1 --> no restart will be done' ) IF( nn_stock == 0 .OR. nn_stock > nitend ) THEN WRITE(ctmp1,*) 'nn_stock = ', nn_stock, ' it is forced to ', nitend @@ -377,7 +470,7 @@ SUBROUTINE dom_nam nn_stock = nitend ENDIF ENDIF -#if ! defined key_iomput +#if ! defined key_xios IF( nn_write == -1 ) CALL ctl_warn( 'nn_write = -1 --> no output files will be done' ) IF ( nn_write == 0 ) THEN WRITE(ctmp1,*) 'nn_write = ', nn_write, ' it is forced to ', nitend @@ -386,68 +479,59 @@ SUBROUTINE dom_nam ENDIF #endif -#if defined key_agrif IF( Agrif_Root() ) THEN -#endif - IF(lwp) WRITE(numout,*) - SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL - CASE ( 1 ) - CALL ioconf_calendar('gregorian') - IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "gregorian", i.e. leap year' - CASE ( 0 ) - CALL ioconf_calendar('noleap') - IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "noleap", i.e. no leap year' - CASE ( 30 ) - CALL ioconf_calendar('360d') - IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "360d", i.e. 360 days in a year' - END SELECT -#if defined key_agrif + IF(lwp) WRITE(numout,*) + SELECT CASE ( nleapy ) !== Choose calendar for IOIPSL ==! + CASE ( 1 ) + CALL ioconf_calendar('gregorian') + IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "gregorian", i.e. leap year' + CASE ( 0 ) + CALL ioconf_calendar('noleap') + IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "noleap", i.e. no leap year' + CASE ( 30 ) + CALL ioconf_calendar('360d') + IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "360d", i.e. 360 days in a year' + END SELECT ENDIF -#endif - - REWIND( numnam_ref ) ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep) - READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) -903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' ) - REWIND( numnam_cfg ) ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep) - READ ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) -904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' ) - IF(lwm) WRITE( numond, namdom ) ! + ! !========================! + ! !== namelist namtile ==! + ! !========================! + ! + READ ( numnam_ref, namtile, IOSTAT = ios, ERR = 905 ) +905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtile in reference namelist' ) + READ ( numnam_cfg, namtile, IOSTAT = ios, ERR = 906 ) +906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtile in configuration namelist' ) + IF(lwm) WRITE( numond, namtile ) + IF(lwp) THEN WRITE(numout,*) - WRITE(numout,*) ' Namelist : namdom --- space & time domain' - WRITE(numout,*) ' linear free surface (=T) ln_linssh = ', ln_linssh - WRITE(numout,*) ' create mesh/mask file ln_meshmask = ', ln_meshmask - WRITE(numout,*) ' treshold to open the isf cavity rn_isfhmin = ', rn_isfhmin, ' [m]' - WRITE(numout,*) ' ocean time step rn_rdt = ', rn_rdt - WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp - WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs + WRITE(numout,*) ' Namelist : namtile --- Domain tiling decomposition' + WRITE(numout,*) ' Tiling (T) or not (F) ln_tile = ', ln_tile + WRITE(numout,*) ' Length of tile in i nn_ltile_i = ', nn_ltile_i + WRITE(numout,*) ' Length of tile in j nn_ltile_j = ', nn_ltile_j + WRITE(numout,*) + IF( ln_tile ) THEN + WRITE(numout,*) ' The domain will be decomposed into tiles of size', nn_ltile_i, 'x', nn_ltile_j + ELSE + WRITE(numout,*) ' Domain tiling will NOT be used' + ENDIF ENDIF ! - ! ! conversion DOCTOR names into model names (this should disappear soon) - atfp = rn_atfp - rdt = rn_rdt - - IF( TRIM(Agrif_CFixed()) == '0' ) THEN - lrxios = ln_xios_read.AND.ln_rstart -!set output file type for XIOS based on NEMO namelist - IF (nn_wxios > 0) lwxios = .TRUE. - nxioso = nn_wxios - ENDIF - #if defined key_netcdf4 - ! ! NetCDF 4 case ("key_netcdf4" defined) - REWIND( numnam_ref ) ! Namelist namnc4 in reference namelist : NETCDF + ! !=======================! + ! !== namelist namnc4 ==! NetCDF 4 case ("key_netcdf4" defined) + ! !=======================! + ! READ ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) 907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist' ) - REWIND( numnam_cfg ) ! Namelist namnc4 in configuration namelist : NETCDF READ ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 ) 908 IF( ios > 0 ) CALL ctl_nam ( ios , 'namnc4 in configuration namelist' ) IF(lwm) WRITE( numond, namnc4 ) IF(lwp) THEN ! control print WRITE(numout,*) - WRITE(numout,*) ' Namelist namnc4 - Netcdf4 chunking parameters' + WRITE(numout,*) ' Namelist namnc4 - Netcdf4 chunking parameters ("key_netcdf4" defined)' WRITE(numout,*) ' number of chunks in i-dimension nn_nchunks_i = ', nn_nchunks_i WRITE(numout,*) ' number of chunks in j-dimension nn_nchunks_j = ', nn_nchunks_j WRITE(numout,*) ' number of chunks in k-dimension nn_nchunks_k = ', nn_nchunks_k @@ -475,62 +559,56 @@ SUBROUTINE dom_ctl !! !! ** Method : compute and print extrema of masked scale factors !!---------------------------------------------------------------------- - INTEGER, DIMENSION(2) :: imi1, imi2, ima1, ima2 - INTEGER, DIMENSION(2) :: iloc ! - REAL(wp) :: ze1min, ze1max, ze2min, ze2max + LOGICAL, DIMENSION(jpi,jpj) :: llmsk + INTEGER, DIMENSION(2) :: imil, imip, imi1, imi2, imal, imap, ima1, ima2 + REAL(wp) :: zglmin, zglmax, zgpmin, zgpmax, ze1min, ze1max, ze2min, ze2max !!---------------------------------------------------------------------- ! - IF(lk_mpp) THEN - CALL mpp_minloc( 'domain', e1t(:,:), tmask_i(:,:), ze1min, imi1 ) - CALL mpp_minloc( 'domain', e2t(:,:), tmask_i(:,:), ze2min, imi2 ) - CALL mpp_maxloc( 'domain', e1t(:,:), tmask_i(:,:), ze1max, ima1 ) - CALL mpp_maxloc( 'domain', e2t(:,:), tmask_i(:,:), ze2max, ima2 ) - ELSE - ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) - ze2min = MINVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) - ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) - ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) - ! - iloc = MINLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) - imi1(1) = iloc(1) + nimpp - 1 - imi1(2) = iloc(2) + njmpp - 1 - iloc = MINLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) - imi2(1) = iloc(1) + nimpp - 1 - imi2(2) = iloc(2) + njmpp - 1 - iloc = MAXLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) - ima1(1) = iloc(1) + nimpp - 1 - ima1(2) = iloc(2) + njmpp - 1 - iloc = MAXLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) - ima2(1) = iloc(1) + nimpp - 1 - ima2(2) = iloc(2) + njmpp - 1 - ENDIF + llmsk = tmask_i(:,:) == 1._wp + ! + CALL mpp_minloc( 'domain', glamt(:,:), llmsk, zglmin, imil ) + CALL mpp_minloc( 'domain', gphit(:,:), llmsk, zgpmin, imip ) + CALL mpp_minloc( 'domain', e1t(:,:), llmsk, ze1min, imi1 ) + CALL mpp_minloc( 'domain', e2t(:,:), llmsk, ze2min, imi2 ) + CALL mpp_maxloc( 'domain', glamt(:,:), llmsk, zglmax, imal ) + CALL mpp_maxloc( 'domain', gphit(:,:), llmsk, zgpmax, imap ) + CALL mpp_maxloc( 'domain', e1t(:,:), llmsk, ze1max, ima1 ) + CALL mpp_maxloc( 'domain', e2t(:,:), llmsk, ze2max, ima2 ) + ! IF(lwp) THEN WRITE(numout,*) WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors' WRITE(numout,*) '~~~~~~~' - WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2) - WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2) - WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2) - WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2) + WRITE(numout,"(14x,'glamt mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmin, imil(1), imil(2) + WRITE(numout,"(14x,'glamt maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmax, imal(1), imal(2) + WRITE(numout,"(14x,'gphit mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmin, imip(1), imip(2) + WRITE(numout,"(14x,'gphit maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmax, imap(1), imap(2) + WRITE(numout,"(14x,' e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2) + WRITE(numout,"(14x,' e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2) + WRITE(numout,"(14x,' e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2) + WRITE(numout,"(14x,' e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2) ENDIF ! END SUBROUTINE dom_ctl - SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) + SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) !!---------------------------------------------------------------------- - !! *** ROUTINE dom_nam *** - !! + !! *** ROUTINE domain_cfg *** + !! !! ** Purpose : read the domain size in domain configuration file !! !! ** Method : read the cn_domcfg NetCDF file !!---------------------------------------------------------------------- - CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name - INTEGER , INTENT(out) :: kk_cfg ! configuration resolution - INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes - INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. - ! - INTEGER :: inum ! local integer + CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name + INTEGER , INTENT(out) :: kk_cfg ! configuration resolution + INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes + LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity + LOGICAL , INTENT(out) :: ldNFold ! North pole folding + CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F + ! + CHARACTER(len=7) :: catt ! 'T', 'F', '-' or 'UNKNOWN' + INTEGER :: inum, iperio, iatt ! local integer REAL(wp) :: zorca_res ! local scalars REAL(wp) :: zperio ! - - INTEGER, DIMENSION(4) :: idvar, idimsz ! size of dimensions @@ -544,66 +622,81 @@ SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) ! CALL iom_open( cn_domcfg, inum ) ! - ! !- ORCA family specificity - IF( iom_varid( inum, 'ORCA' , ldstop = .FALSE. ) > 0 .AND. & - & iom_varid( inum, 'ORCA_index' , ldstop = .FALSE. ) > 0 ) THEN - ! - cd_cfg = 'ORCA' - CALL iom_get( inum, 'ORCA_index', zorca_res ) ; kk_cfg = NINT( zorca_res ) - ! - IF(lwp) THEN - WRITE(numout,*) ' .' - WRITE(numout,*) ' ==>>> ORCA configuration ' - WRITE(numout,*) ' .' + CALL iom_getatt( inum, 'CfgName', cd_cfg ) ! returns 'UNKNOWN' if not found + CALL iom_getatt( inum, 'CfgIndex', kk_cfg ) ! returns -999 if not found + ! + ! ------- keep compatibility with OLD VERSION... start ------- + IF( cd_cfg == 'UNKNOWN' .AND. kk_cfg == -999 ) THEN + IF( iom_varid( inum, 'ORCA' , ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'ORCA_index' , ldstop = .FALSE. ) > 0 ) THEN + ! + cd_cfg = 'ORCA' + CALL iom_get( inum, 'ORCA_index', zorca_res ) ; kk_cfg = NINT( zorca_res ) + ! + ELSE + CALL iom_getatt( inum, 'cn_cfg', cd_cfg ) ! returns 'UNKNOWN' if not found + CALL iom_getatt( inum, 'nn_cfg', kk_cfg ) ! returns -999 if not found ENDIF - ! - ELSE !- cd_cfg & k_cfg are not used - cd_cfg = 'UNKNOWN' - kk_cfg = -9999999 - !- or they may be present as global attributes - !- (netcdf only) - CALL iom_getatt( inum, 'cn_cfg', cd_cfg ) ! returns ! if not found - CALL iom_getatt( inum, 'nn_cfg', kk_cfg ) ! returns -999 if not found - IF( TRIM(cd_cfg) == '!') cd_cfg = 'UNKNOWN' - IF( kk_cfg == -999 ) kk_cfg = -9999999 - ! ENDIF - ! + ! ------- keep compatibility with OLD VERSION... end ------- + ! idvar = iom_varid( inum, 'e3t_0', kdimsz = idimsz ) ! use e3t_0, that must exist, to get jp(ijk)glo kpi = idimsz(1) kpj = idimsz(2) kpk = idimsz(3) - CALL iom_get( inum, 'jperio', zperio ) ; kperio = NINT( zperio ) + ! + CALL iom_getatt( inum, 'Iperio', iatt ) ; ldIperio = iatt == 1 ! returns -999 if not found -> default = .false. + CALL iom_getatt( inum, 'Jperio', iatt ) ; ldJperio = iatt == 1 ! returns -999 if not found -> default = .false. + CALL iom_getatt( inum, 'NFold', iatt ) ; ldNFold = iatt == 1 ! returns -999 if not found -> default = .false. + CALL iom_getatt( inum, 'NFtype', catt ) ! returns 'UNKNOWN' if not found + IF( LEN_TRIM(catt) == 1 ) THEN ; cdNFtype = TRIM(catt) + ELSE ; cdNFtype = '-' + ENDIF + ! + ! ------- keep compatibility with OLD VERSION... start ------- + IF( iatt == -999 .AND. catt == 'UNKNOWN' .AND. iom_varid( inum, 'jperio', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( inum, 'jperio', zperio ) ; iperio = NINT( zperio ) + ldIperio = iperio == 1 .OR. iperio == 4 .OR. iperio == 6 .OR. iperio == 7 ! i-periodicity + ldJperio = iperio == 2 .OR. iperio == 7 ! j-periodicity + ldNFold = iperio >= 3 .AND. iperio <= 6 ! North pole folding + IF( iperio == 3 .OR. iperio == 4 ) THEN ; cdNFtype = 'T' ! folding at T point + ELSEIF( iperio == 5 .OR. iperio == 6 ) THEN ; cdNFtype = 'F' ! folding at F point + ELSE ; cdNFtype = '-' ! default value + ENDIF + ENDIF + ! ------- keep compatibility with OLD VERSION... end ------- + ! CALL iom_close( inum ) ! IF(lwp) THEN - WRITE(numout,*) ' cn_cfg = ', TRIM(cd_cfg), ' nn_cfg = ', kk_cfg - WRITE(numout,*) ' jpiglo = ', kpi - WRITE(numout,*) ' jpjglo = ', kpj + WRITE(numout,*) ' .' + WRITE(numout,*) ' ==>>> ', TRIM(cn_cfg), ' configuration ' + WRITE(numout,*) ' .' + WRITE(numout,*) ' nn_cfg = ', kk_cfg + WRITE(numout,*) ' Ni0glo = ', kpi + WRITE(numout,*) ' Nj0glo = ', kpj WRITE(numout,*) ' jpkglo = ', kpk - WRITE(numout,*) ' type of global domain lateral boundary jperio = ', kperio ENDIF - ! + ! END SUBROUTINE domain_cfg - - + + SUBROUTINE cfg_write !!---------------------------------------------------------------------- !! *** ROUTINE cfg_write *** - !! - !! ** Purpose : Create the "cn_domcfg_out" file, a NetCDF file which - !! contains all the ocean domain informations required to + !! + !! ** Purpose : Create the "cn_domcfg_out" file, a NetCDF file which + !! contains all the ocean domain informations required to !! define an ocean configuration. !! !! ** Method : Write in a file all the arrays required to set up an !! ocean configuration. !! - !! ** output file : domcfg_out.nc : domain size, characteristics, horizontal + !! ** output file : domcfg_out.nc : domain size, characteristics, horizontal !! mesh, Coriolis parameter, and vertical scale factors !! NB: also contain ORCA family information !!---------------------------------------------------------------------- INTEGER :: ji, jj, jk ! dummy loop indices - INTEGER :: izco, izps, isco, icav INTEGER :: inum ! local units CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) REAL(wp), DIMENSION(jpi,jpj) :: z2d ! workspace @@ -616,39 +709,30 @@ SUBROUTINE cfg_write ! ! ============================= ! ! ! create 'domcfg_out.nc' file ! ! ! ============================= ! - ! + ! clnam = cn_domcfg_out ! filename (configuration information) CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) - ! - ! !== ORCA family specificities ==! - IF( TRIM(cn_cfg) == "orca" .OR. TRIM(cn_cfg) == "ORCA" ) THEN - CALL iom_rstput( 0, 0, inum, 'ORCA' , 1._wp , ktype = jp_i4 ) - CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 ) - ENDIF + ! !== Configuration specificities ==! ! - ! !== global domain size ==! - ! - CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 ) - CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 ) - CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpk , wp), ktype = jp_i4 ) + CALL iom_putatt( inum, 'CfgName', TRIM(cn_cfg) ) + CALL iom_putatt( inum, 'CfgIndex', nn_cfg ) ! ! !== domain characteristics ==! ! ! ! lateral boundary of the global domain - CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 ) - ! + CALL iom_putatt( inum, 'Iperio', COUNT( (/l_Iperio/) ) ) + CALL iom_putatt( inum, 'Jperio', COUNT( (/l_Jperio/) ) ) + CALL iom_putatt( inum, 'NFold', COUNT( (/l_NFold /) ) ) + CALL iom_putatt( inum, 'NFtype', c_NFtype ) + ! ! type of vertical coordinate - IF( ln_zco ) THEN ; izco = 1 ; ELSE ; izco = 0 ; ENDIF - IF( ln_zps ) THEN ; izps = 1 ; ELSE ; izps = 0 ; ENDIF - IF( ln_sco ) THEN ; isco = 1 ; ELSE ; isco = 0 ; ENDIF - CALL iom_rstput( 0, 0, inum, 'ln_zco' , REAL( izco, wp), ktype = jp_i4 ) - CALL iom_rstput( 0, 0, inum, 'ln_zps' , REAL( izps, wp), ktype = jp_i4 ) - CALL iom_rstput( 0, 0, inum, 'ln_sco' , REAL( isco, wp), ktype = jp_i4 ) - ! + IF(ln_zco) CALL iom_putatt( inum, 'VertCoord', 'zco' ) + IF(ln_zps) CALL iom_putatt( inum, 'VertCoord', 'zps' ) + IF(ln_sco) CALL iom_putatt( inum, 'VertCoord', 'sco' ) + ! ! ocean cavities under iceshelves - IF( ln_isfcav ) THEN ; icav = 1 ; ELSE ; icav = 0 ; ENDIF - CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 ) + CALL iom_putatt( inum, 'IsfCav', COUNT( (/ln_isfcav/) ) ) ! ! !== horizontal mesh ! ! @@ -656,12 +740,12 @@ SUBROUTINE cfg_write CALL iom_rstput( 0, 0, inum, 'glamu', glamu, ktype = jp_r8 ) CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 ) CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 ) - ! + ! CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 ) ! longitude CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 ) CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 ) CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 ) - ! + ! CALL iom_rstput( 0, 0, inum, 'e1t' , e1t , ktype = jp_r8 ) ! i-scale factors (e1.) CALL iom_rstput( 0, 0, inum, 'e1u' , e1u , ktype = jp_r8 ) CALL iom_rstput( 0, 0, inum, 'e1v' , e1v , ktype = jp_r8 ) @@ -676,7 +760,7 @@ SUBROUTINE cfg_write CALL iom_rstput( 0, 0, inum, 'ff_t' , ff_t , ktype = jp_r8 ) ! ! !== vertical mesh ==! - ! + ! CALL iom_rstput( 0, 0, inum, 'e3t_1d' , e3t_1d , ktype = jp_r8 ) ! reference 1D-coordinate CALL iom_rstput( 0, 0, inum, 'e3w_1d' , e3w_1d , ktype = jp_r8 ) ! @@ -687,7 +771,7 @@ SUBROUTINE cfg_write CALL iom_rstput( 0, 0, inum, 'e3w_0' , e3w_0 , ktype = jp_r8 ) CALL iom_rstput( 0, 0, inum, 'e3uw_0' , e3uw_0 , ktype = jp_r8 ) CALL iom_rstput( 0, 0, inum, 'e3vw_0' , e3vw_0 , ktype = jp_r8 ) - ! + ! ! !== wet top and bottom level ==! (caution: multiplied by ssmask) ! CALL iom_rstput( 0, 0, inum, 'top_level' , REAL( mikt, wp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points (ISF) @@ -701,14 +785,9 @@ SUBROUTINE cfg_write IF( ll_wd ) THEN ! wetting and drying domain CALL iom_rstput( 0, 0, inum, 'ht_0' , ht_0 , ktype = jp_r8 ) ENDIF - ! - ! Add some global attributes ( netcdf only ) - CALL iom_putatt( inum, 'nn_cfg', nn_cfg ) - CALL iom_putatt( inum, 'cn_cfg', TRIM(cn_cfg) ) - ! - ! ! ============================ - ! ! close the files - ! ! ============================ + ! ! ============================ ! + ! ! close the files + ! ! ============================ ! CALL iom_close( inum ) ! END SUBROUTINE cfg_write diff --git a/MY_SRC/domzgr.F90 b/MY_SRC/domzgr.F90 index defae11..85f89ed 100755 --- a/MY_SRC/domzgr.F90 +++ b/MY_SRC/domzgr.F90 @@ -43,10 +43,10 @@ MODULE domzgr PUBLIC dom_zgr ! called by dom_init.F90 !! * Substitutions -# include "vectopt_loop_substitute.h90" +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: domzgr.F90 10425 2018-12-19 21:54:16Z smasson $ + !! $Id: domzgr.F90 15157 2021-07-29 08:28:32Z techene $ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -70,9 +70,13 @@ SUBROUTINE dom_zgr( k_top, k_bot ) !!---------------------------------------------------------------------- INTEGER, DIMENSION(:,:), INTENT(out) :: k_top, k_bot ! ocean first and last level indices ! - INTEGER :: jk ! dummy loop index + INTEGER :: ji,jj,jk ! dummy loop index + INTEGER :: ikt, ikb ! top/bot index INTEGER :: ioptio, ibat, ios ! local integer + INTEGER :: is_mbkuvf ! ==0 if mbku, mbkv, mbkf to be computed REAL(wp) :: zrefdep ! depth of the reference level (~10m) + REAL(wp), DIMENSION(jpi,jpj ) :: zmsk + REAL(wp), DIMENSION(jpi,jpj,2) :: ztopbot !!---------------------------------------------------------------------- ! IF(lwp) THEN ! Control print @@ -93,15 +97,13 @@ SUBROUTINE dom_zgr( k_top, k_bot ) & gdept_0 , gdepw_0 , & ! gridpoints depth & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors - & k_top , k_bot ) ! 1st & last ocean level + & k_top , k_bot , & ! 1st & last ocean level + & is_mbkuvf, mbku, mbkv, mbkf ) ! U/V/F points bottom levels ! -! DRM 07/08/17 - Modify the top_level (ztop) and bottom_level (zbot) arrays to mask fake ocean points in -! Antarctica. Need to convert the indices to the local values. - k_top( mi0(5), mj0(5):mj0(405) ) = 0 - k_bot( mi0(5), mj0(5):mj0(405) ) = 0 ELSE !== User defined configuration ==! IF(lwp) WRITE(numout,*) IF(lwp) WRITE(numout,*) ' User defined vertical mesh (usr_def_zgr)' + is_mbkuvf = 0 ! CALL usr_def_zgr( ln_zco , ln_zps , ln_sco, ln_isfcav, & & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth @@ -110,18 +112,60 @@ SUBROUTINE dom_zgr( k_top, k_bot ) & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors & k_top , k_bot ) ! 1st & last ocean level ! + ! make sure that periodicities are properly applied + CALL lbc_lnk( 'dom_zgr', gdept_0, 'T', 1._wp, gdepw_0, 'W', 1._wp, & + & e3t_0, 'T', 1._wp, e3u_0, 'U', 1._wp, e3v_0, 'V', 1._wp, e3f_0, 'F', 1._wp, & + & e3w_0, 'W', 1._wp, e3uw_0, 'U', 1._wp, e3vw_0, 'V', 1._wp, & + & kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries + ztopbot(:,:,1) = REAL(k_top, wp) + ztopbot(:,:,2) = REAL(k_bot, wp) + CALL lbc_lnk( 'dom_zgr', ztopbot, 'T', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries + k_top(:,:) = NINT(ztopbot(:,:,1)) + k_bot(:,:) = NINT(ztopbot(:,:,2)) + ! + ENDIF + ! + ! the following is mandatory + ! make sure that closed boundaries are correctly defined in k_top that will be used to compute all mask arrays + ! + zmsk(:,:) = 1._wp ! default: no closed boundaries + IF( .NOT. l_Iperio ) THEN ! E-W closed: + zmsk( mi0( 1+nn_hls):mi1( 1+nn_hls),:) = 0._wp ! first column of inner global domain at 0 + zmsk( mi0(jpiglo-nn_hls):mi1(jpiglo-nn_hls),:) = 0._wp ! last column of inner global domain at 0 + ENDIF + IF( .NOT. l_Jperio ) THEN ! S closed: + zmsk(:,mj0( 1+nn_hls):mj1( 1+nn_hls) ) = 0._wp ! first line of inner global domain at 0 ENDIF + IF( .NOT. ( l_Jperio .OR. l_NFold ) ) THEN ! N closed: + zmsk(:,mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls) ) = 0._wp ! last line of inner global domain at 0 + ENDIF + CALL lbc_lnk( 'usrdef_zgr', zmsk, 'T', 1. ) ! set halos + k_top(:,:) = k_top(:,:) * NINT( zmsk(:,:) ) ! -!!gm to be remove when removing the OLD definition of e3 scale factors so that gde3w disappears +#if ! defined key_qco && ! defined key_linssh + ! OLD implementation of coordinate (not with 'key_qco' or 'key_linssh') + ! gde3w_0 has to be defined +!!gm to be remove when removing the OLD definition of e3 scale factors so that gde3w_0=gdept_0 +!!gm therefore gde3w_0 disappears ! Compute gde3w_0 (vertical sum of e3w) gde3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) DO jk = 2, jpk gde3w_0(:,:,jk) = gde3w_0(:,:,jk-1) + e3w_0(:,:,jk) END DO +#endif ! ! Any closed seas (defined by closea_mask > 0 in domain_cfg file) to be filled ! in at runtime if ln_closea=.false. - IF( .NOT.ln_closea ) CALL clo_bat( k_top, k_bot ) + IF( ln_closea ) THEN + IF ( ln_maskcs ) THEN + ! mask all the closed sea + CALL clo_msk( k_top, k_bot, mask_opnsea, 'mask_opensea' ) + ELSE IF ( ln_mask_csundef ) THEN + ! defined closed sea are kept + ! mask all the undefined closed sea + CALL clo_msk( k_top, k_bot, mask_csundef, 'mask_csundef' ) + END IF + END IF ! IF(lwp) THEN ! Control print WRITE(numout,*) @@ -140,9 +184,16 @@ SUBROUTINE dom_zgr( k_top, k_bot ) ! ! top/bottom ocean level indices for t-, u- and v-points (f-point also for top) - CALL zgr_top_bot( k_top, k_bot ) ! with a minimum value set to 1 - - + CALL zgr_top_bot( k_top, k_bot, is_mbkuvf ) ! with a minimum value set to 1 + ! + ! ! ice shelf draft and bathymetry + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ikt = mikt(ji,jj) + ikb = mbkt(ji,jj) + bathy (ji,jj) = gdepw_0(ji,jj,ikb+1) + risfdep(ji,jj) = gdepw_0(ji,jj,ikt ) + END_2D + ! ! ! deepest/shallowest W level Above/Below ~10m !!gm BUG in s-coordinate this does not work! zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_1d ) ! ref. depth with tolerance (10% of minimum layer thickness) @@ -150,18 +201,24 @@ SUBROUTINE dom_zgr( k_top, k_bot ) nla10 = nlb10 - 1 ! deepest W level Above ~10m !!gm end bug ! - IF( nprint == 1 .AND. lwp ) THEN + IF( lwp ) THEN WRITE(numout,*) ' MIN val k_top ', MINVAL( k_top(:,:) ), ' MAX ', MAXVAL( k_top(:,:) ) WRITE(numout,*) ' MIN val k_bot ', MINVAL( k_bot(:,:) ), ' MAX ', MAXVAL( k_bot(:,:) ) WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ), & - & ' w ', MINVAL( gdepw_0(:,:,:) ), '3w ', MINVAL( gde3w_0(:,:,:) ) +#if ! defined key_qco && ! defined key_linssh + & '3w ', MINVAL( gde3w_0(:,:,:) ), & +#endif + & ' w ', MINVAL( gdepw_0(:,:,:) ) WRITE(numout,*) ' MIN val e3 t ', MINVAL( e3t_0(:,:,:) ), ' f ', MINVAL( e3f_0(:,:,:) ), & & ' u ', MINVAL( e3u_0(:,:,:) ), ' u ', MINVAL( e3v_0(:,:,:) ), & & ' uw', MINVAL( e3uw_0(:,:,:) ), ' vw', MINVAL( e3vw_0(:,:,:)), & & ' w ', MINVAL( e3w_0(:,:,:) ) WRITE(numout,*) ' MAX val depth t ', MAXVAL( gdept_0(:,:,:) ), & - & ' w ', MAXVAL( gdepw_0(:,:,:) ), '3w ', MAXVAL( gde3w_0(:,:,:) ) +#if ! defined key_qco && ! defined key_linssh + & '3w ', MINVAL( gde3w_0(:,:,:) ), & +#endif + & ' w ', MINVAL( gdepw_0(:,:,:) ) WRITE(numout,*) ' MAX val e3 t ', MAXVAL( e3t_0(:,:,:) ), ' f ', MAXVAL( e3f_0(:,:,:) ), & & ' u ', MAXVAL( e3u_0(:,:,:) ), ' u ', MAXVAL( e3v_0(:,:,:) ), & & ' uw', MAXVAL( e3uw_0(:,:,:) ), ' vw', MAXVAL( e3vw_0(:,:,:) ), & @@ -176,7 +233,8 @@ SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of ve & pdept , pdepw , & ! 3D t & w-points depth & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors & pe3w , pe3uw , pe3vw , & ! - - - - & k_top , k_bot ) ! top & bottom ocean level + & k_top , k_bot , & ! top & bottom ocean level + & k_mbkuvf , k_bot_u , k_bot_v , k_bot_f ) ! U/V/F points bottom levels !!--------------------------------------------------------------------- !! *** ROUTINE zgr_read *** !! @@ -191,11 +249,14 @@ SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of ve REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! - - - INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top , k_bot ! first & last ocean level + INTEGER , INTENT(out) :: k_mbkuvf ! ==1 if mbku, mbkv, mbkf are in file + INTEGER , DIMENSION(:,:) , INTENT(out) :: k_bot_u , k_bot_v, k_bot_f ! bottom levels at U/V/F points ! - INTEGER :: jk ! dummy loop index - INTEGER :: inum ! local logical unit + INTEGER :: ji,jj,jk ! dummy loop index + INTEGER :: inum, iatt REAL(WP) :: z_zco, z_zps, z_sco, z_cav REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + CHARACTER(len=7) :: catt ! 'zco', 'zps, 'sco' or 'UNKNOWN' !!---------------------------------------------------------------------- ! IF(lwp) THEN @@ -207,28 +268,42 @@ SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of ve CALL iom_open( cn_domcfg, inum ) ! ! !* type of vertical coordinate - CALL iom_get( inum, 'ln_zco' , z_zco ) - CALL iom_get( inum, 'ln_zps' , z_zps ) - CALL iom_get( inum, 'ln_sco' , z_sco ) - IF( z_zco == 0._wp ) THEN ; ld_zco = .false. ; ELSE ; ld_zco = .true. ; ENDIF - IF( z_zps == 0._wp ) THEN ; ld_zps = .false. ; ELSE ; ld_zps = .true. ; ENDIF - IF( z_sco == 0._wp ) THEN ; ld_sco = .false. ; ELSE ; ld_sco = .true. ; ENDIF - ! + CALL iom_getatt( inum, 'VertCoord', catt ) ! returns 'UNKNOWN' if not found + ld_zco = catt == 'zco' ! default = .false. + ld_zps = catt == 'zps' ! default = .false. + ld_sco = catt == 'sco' ! default = .false. ! !* ocean cavities under iceshelves - CALL iom_get( inum, 'ln_isfcav', z_cav ) - IF( z_cav == 0._wp ) THEN ; ld_isfcav = .false. ; ELSE ; ld_isfcav = .true. ; ENDIF + CALL iom_getatt( inum, 'IsfCav', iatt ) ! returns -999 if not found + ld_isfcav = iatt == 1 ! default = .false. + ! + ! ------- keep compatibility with OLD VERSION... start ------- + IF( catt == 'UNKNOWN' ) THEN + CALL iom_get( inum, 'ln_zco', z_zco ) ; ld_zco = z_zco /= 0._wp + CALL iom_get( inum, 'ln_zps', z_zps ) ; ld_zps = z_zps /= 0._wp + CALL iom_get( inum, 'ln_sco', z_sco ) ; ld_sco = z_sco /= 0._wp + ENDIF + IF( iatt == -999 ) THEN + CALL iom_get( inum, 'ln_isfcav', z_cav ) ; ld_isfcav = z_cav /= 0._wp + ENDIF + ! ------- keep compatibility with OLD VERSION... end ------- + ! + ! !* ocean top and bottom level + CALL iom_get( inum, jpdom_global, 'top_level' , z2d ) ! 1st wet T-points (ISF) + k_top(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_global, 'bottom_level' , z2d ) ! last wet T-points + k_bot(:,:) = NINT( z2d(:,:) ) ! ! !* vertical scale factors CALL iom_get( inum, jpdom_unknown, 'e3t_1d' , pe3t_1d ) ! 1D reference coordinate CALL iom_get( inum, jpdom_unknown, 'e3w_1d' , pe3w_1d ) ! - CALL iom_get( inum, jpdom_data, 'e3t_0' , pe3t , lrowattr=ln_use_jattr ) ! 3D coordinate - CALL iom_get( inum, jpdom_data, 'e3u_0' , pe3u , lrowattr=ln_use_jattr ) - CALL iom_get( inum, jpdom_data, 'e3v_0' , pe3v , lrowattr=ln_use_jattr ) - CALL iom_get( inum, jpdom_data, 'e3f_0' , pe3f , lrowattr=ln_use_jattr ) - CALL iom_get( inum, jpdom_data, 'e3w_0' , pe3w , lrowattr=ln_use_jattr ) - CALL iom_get( inum, jpdom_data, 'e3uw_0' , pe3uw , lrowattr=ln_use_jattr ) - CALL iom_get( inum, jpdom_data, 'e3vw_0' , pe3vw , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_global, 'e3t_0' , pe3t , cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy ) ! 3D coordinate + CALL iom_get( inum, jpdom_global, 'e3u_0' , pe3u , cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3v_0' , pe3v , cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3f_0' , pe3f , cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3w_0' , pe3w , cd_type = 'W', psgn = 1._wp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3uw_0' , pe3uw, cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3vw_0' , pe3vw, cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) ! ! !* depths ! !- old depth definition (obsolescent feature) @@ -240,12 +315,21 @@ SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of ve & ' depths at t- and w-points read in the domain configuration file') CALL iom_get( inum, jpdom_unknown, 'gdept_1d', pdept_1d ) CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', pdepw_1d ) - CALL iom_get( inum, jpdom_data , 'gdept_0' , pdept , lrowattr=ln_use_jattr ) - CALL iom_get( inum, jpdom_data , 'gdepw_0' , pdepw , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_global , 'gdept_0' , pdept, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global , 'gdepw_0' , pdepw, kfill = jpfillcopy ) ! ELSE !- depths computed from e3. scale factors CALL e3_to_depth( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d ) ! 1D reference depth CALL e3_to_depth( pe3t , pe3w , pdept , pdepw ) ! 3D depths +#if defined key_qco && key_isf + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpk ) ! vertical sum at partial cell xxxx other level + IF( jk == k_top(ji,jj) ) THEN ! first ocean point : partial cell + pdept(ji,jj,jk) = pdepw(ji,jj,jk ) + 0.5_wp * pe3w(ji,jj,jk) ! = risfdep + 1/2 e3w_0(mikt) + ELSE ! other levels + pdept(ji,jj,jk) = pdept(ji,jj,jk-1) + pe3w(ji,jj,jk) + ENDIF + END_3D +#endif IF(lwp) THEN WRITE(numout,*) WRITE(numout,*) ' Reference 1D z-coordinate depth and scale factors:' @@ -254,11 +338,18 @@ SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of ve ENDIF ENDIF ! - ! !* ocean top and bottom level - CALL iom_get( inum, jpdom_data, 'top_level' , z2d , lrowattr=ln_use_jattr ) ! 1st wet T-points (ISF) - k_top(:,:) = NINT( z2d(:,:) ) - CALL iom_get( inum, jpdom_data, 'bottom_level' , z2d , lrowattr=ln_use_jattr ) ! last wet T-points - k_bot(:,:) = NINT( z2d(:,:) ) + IF( iom_varid( inum, 'mbku', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' mbku, mbkv & mbkf read in ', TRIM(cn_domcfg), ' file' + CALL iom_get( inum, jpdom_global, 'mbku', z2d, cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) + k_bot_u(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_global, 'mbkv', z2d, cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) + k_bot_v(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_global, 'mbkf', z2d, cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy ) + k_bot_f(:,:) = NINT( z2d(:,:) ) + k_mbkuvf = 1 + ELSE + k_mbkuvf = 0 + ENDIF ! ! reference depth for negative bathy (wetting and drying only) IF( ll_wd ) CALL iom_get( inum, 'rn_wd_ref_depth' , ssh_ref ) @@ -268,7 +359,7 @@ SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of ve END SUBROUTINE zgr_read - SUBROUTINE zgr_top_bot( k_top, k_bot ) + SUBROUTINE zgr_top_bot( k_top, k_bot, k_mbkuvf ) !!---------------------------------------------------------------------- !! *** ROUTINE zgr_top_bot *** !! @@ -280,10 +371,11 @@ SUBROUTINE zgr_top_bot( k_top, k_bot ) !! ocean level at t-, u- & v-points !! (min value = 1) !! ** Action : mbkt, mbku, mbkv : vertical indices of the deeptest - !! ocean level at t-, u- & v-points + !! mbkf ocean level at t-, u-, v- & f-points !! (min value = 1 over land) !!---------------------------------------------------------------------- INTEGER , DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! top & bottom ocean level indices + INTEGER , INTENT(in) :: k_mbkuvf ! flag to recompute mbku, mbkv, mbkf ! INTEGER :: ji, jj ! dummy loop indices REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace @@ -299,23 +391,65 @@ SUBROUTINE zgr_top_bot( k_top, k_bot ) ! ! N.B. top k-index of W-level = mikt ! ! bottom k-index of W-level = mbkt+1 - DO jj = 1, jpjm1 - DO ji = 1, jpim1 - miku(ji,jj) = MAX( mikt(ji+1,jj ) , mikt(ji,jj) ) - mikv(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj) ) - mikf(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj), mikt(ji+1,jj ), mikt(ji+1,jj+1) ) - ! + DO_2D( 0, 0, 0, 0 ) + miku(ji,jj) = MAX( mikt(ji+1,jj ) , mikt(ji,jj) ) + mikv(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj) ) + mikf(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj), mikt(ji+1,jj ), mikt(ji+1,jj+1) ) + END_2D + + IF ( k_mbkuvf==0 ) THEN + IF(lwp) WRITE(numout,*) ' mbku, mbkv, mbkf computed from mbkt' + DO_2D( 0, 0, 0, 0 ) mbku(ji,jj) = MIN( mbkt(ji+1,jj ) , mbkt(ji,jj) ) mbkv(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj) ) - END DO - END DO - ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk - zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) - zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) - zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1. ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) + mbkf(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj), mbkt(ji+1,jj ), mbkt(ji+1,jj+1) ) + END_2D + ELSE + IF(lwp) WRITE(numout,*) ' mbku, mbkv, mbkf read from file' + ! Use mbku, mbkv, mbkf from file + ! Ensure these are lower than expected bottom level deduced from mbkt + DO_2D( 0, 0, 0, 0 ) + mbku(ji,jj) = MIN( mbku(ji,jj), mbkt(ji+1,jj ) , mbkt(ji,jj) ) + mbkv(ji,jj) = MIN( mbkv(ji,jj), mbkt(ji ,jj+1) , mbkt(ji,jj) ) + mbkf(ji,jj) = MIN( mbkf(ji,jj), mbkt(ji ,jj+1) , mbkt(ji,jj), mbkt(ji+1,jj ), mbkt(ji+1,jj+1) ) + END_2D + ENDIF + ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( miku(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) + miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mikv(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) + mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mikf(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) + mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) ! - zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) - zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mbku(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) + mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mbkv(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) + mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mbkf(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) + mbkf(:,:) = MAX( NINT( zk(:,:) ), 1 ) ! END SUBROUTINE zgr_top_bot diff --git a/MY_SRC/dtatsd.F90 b/MY_SRC/dtatsd.F90 index ff68b74..6d5d0c1 100755 --- a/MY_SRC/dtatsd.F90 +++ b/MY_SRC/dtatsd.F90 @@ -5,8 +5,8 @@ MODULE dtatsd !!====================================================================== !! History : OPA ! 1991-03 () Original code !! - ! 1992-07 (M. Imbard) - !! 8.0 ! 1999-10 (M.A. Foujols, M. Imbard) NetCDF FORMAT - !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 8.0 ! 1999-10 (M.A. Foujols, M. Imbard) NetCDF FORMAT + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module !! 3.3 ! 2010-10 (C. Bricaud, S. Masson) use of fldread !! 3.4 ! 2010-11 (G. Madec, C. Ethe) Merge of dtatem and dtasal + remove CPP keys !!---------------------------------------------------------------------- @@ -17,12 +17,13 @@ MODULE dtatsd USE oce ! ocean dynamics and tracers USE phycst ! physical constants USE dom_oce ! ocean space and time domain + USE domtile USE fldread ! read input fields ! USE in_out_manager ! I/O manager USE lib_mpp ! MPP library USE iom - + IMPLICIT NONE PRIVATE @@ -33,16 +34,17 @@ MODULE dtatsd LOGICAL , PUBLIC :: ln_tsd_init !: T & S data flag LOGICAL , PUBLIC :: ln_tsd_interp !: vertical interpolation flag LOGICAL , PUBLIC :: ln_tsd_dmp !: internal damping toward input data flag - + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tsd ! structure of input SST (file informations, fields read) INTEGER :: jpk_init , inum_dta INTEGER :: id ,linum ! local integers INTEGER :: zdim(4) - + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: dtatsd.F90 11536 2019-09-11 13:54:18Z smasson $ + !! $Id: dtatsd.F90 14834 2021-05-11 09:24:44Z hadcv $ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -50,11 +52,11 @@ MODULE dtatsd SUBROUTINE dta_tsd_init( ld_tradmp ) !!---------------------------------------------------------------------- !! *** ROUTINE dta_tsd_init *** - !! - !! ** Purpose : initialisation of T & S input data - !! + !! + !! ** Purpose : initialisation of T & S input data + !! !! ** Method : - Read namtsd namelist - !! - allocates T & S data structure + !! - allocates T & S data structure !!---------------------------------------------------------------------- LOGICAL, INTENT(in), OPTIONAL :: ld_tradmp ! force the initialization when tradp is used ! @@ -71,16 +73,14 @@ SUBROUTINE dta_tsd_init( ld_tradmp ) ! Initialisation ierr0 = 0 ; ierr1 = 0 ; ierr2 = 0 ; ierr3 = 0 ; ierr4 = 0 ; ierr5 = 0 ! - REWIND( numnam_ref ) ! Namelist namtsd in reference namelist : READ ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtsd in reference namelist' ) - REWIND( numnam_cfg ) ! Namelist namtsd in configuration namelist : Parameters of the run READ ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtsd in configuration namelist' ) IF(lwm) WRITE ( numond, namtsd ) IF( PRESENT( ld_tradmp ) ) ln_tsd_dmp = .TRUE. ! forces the initialization when tradmp is used - + IF(lwp) THEN ! control print WRITE(numout,*) WRITE(numout,*) 'dta_tsd_init : Temperature & Salinity data ' @@ -160,125 +160,150 @@ END SUBROUTINE dta_tsd_init SUBROUTINE dta_tsd( kt, ptsd ) !!---------------------------------------------------------------------- !! *** ROUTINE dta_tsd *** - !! + !! !! ** Purpose : provides T and S data at kt - !! + !! !! ** Method : - call fldread routine - !! - ORCA_R2: add some hand made alteration to read data - !! - 'key_orca_lev10' interpolates on 10 times more levels + !! - ORCA_R2: add some hand made alteration to read data !! - s- or mixed z-s coordinate: vertical interpolation on model mesh !! - ln_tsd_dmp=F: deallocates the T-S data structure !! as T-S data are no are used !! !! ** Action : ptsd T-S data on medl mesh and interpolated at time-step kt !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kt ! ocean time-step - REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: ptsd ! T & S data + INTEGER , INTENT(in ) :: kt ! ocean time-step + REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data ! INTEGER :: ji, jj, jk, jl, jk_init ! dummy loop indicies INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers + INTEGER, DIMENSION(jpts), SAVE :: irec_b, irec_n REAL(wp):: zl, zi ! local scalars !!---------------------------------------------------------------------- ! - CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only for the full domain + IF( ln_tile ) CALL dom_tile_stop( ldhold=.TRUE. ) ! Use full domain + CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==! ! ! !!gm This should be removed from the code ===>>>> T & S files has to be changed - ! - ! !== ORCA_R2 configuration and T & S damping ==! - IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN - IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN ! some hand made alterations - ! - ij0 = 101 ; ij1 = 109 ! Reduced T & S in the Alboran Sea - ii0 = 141 ; ii1 = 155 - DO jj = mj0(ij0), mj1(ij1) - DO ji = mi0(ii0), mi1(ii1) - sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp - sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp - sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp - ! - sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp - sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp - sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp - sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp - END DO - END DO - ij0 = 87 ; ij1 = 96 ! Reduced temperature in Red Sea - ii0 = 148 ; ii1 = 160 - sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 4:10 ) = 7.0_wp - sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp - sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp + ! + ! !== ORCA_R2 configuration and T & S damping ==! + IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN + IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN ! some hand made alterations + irec_n(jp_tem) = sf_tsd(jp_tem)%nrec(2,sf_tsd(jp_tem)%naa) ! Determine if there is new data (ln_tint = F) + irec_n(jp_sal) = sf_tsd(jp_sal)%nrec(2,sf_tsd(jp_sal)%naa) ! If not, then do not apply the increments + IF( kt == nit000 ) irec_b(:) = -1 + ! + ij0 = 101 + nn_hls ; ij1 = 109 + nn_hls ! Reduced T & S in the Alboran Sea + ii0 = 141 + nn_hls - 1 ; ii1 = 155 + nn_hls - 1 + IF( sf_tsd(jp_tem)%ln_tint .OR. irec_n(jp_tem) /= irec_b(jp_tem) ) THEN + DO jj = mj0(ij0), mj1(ij1) + DO ji = mi0(ii0), mi1(ii1) + sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp + sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp + sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp + END DO + END DO + irec_b(jp_tem) = irec_n(jp_tem) + ENDIF + ! + IF( sf_tsd(jp_sal)%ln_tint .OR. irec_n(jp_sal) /= irec_b(jp_sal) ) THEN + DO jj = mj0(ij0), mj1(ij1) + DO ji = mi0(ii0), mi1(ii1) + sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp + sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp + sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp + sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp + END DO + END DO + irec_b(jp_sal) = irec_n(jp_sal) + ENDIF + ! + ij0 = 87 + nn_hls ; ij1 = 96 + nn_hls ! Reduced temperature in Red Sea + ii0 = 148 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1 + sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 4:10 ) = 7.0_wp + sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp + sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp + ENDIF ENDIF - ENDIF !!gm end + IF( ln_tile ) CALL dom_tile_start( ldhold=.TRUE. ) ! Revert to tile domain + ENDIF ! - IF( ln_tsd_interp ) THEN + IF( ln_tsd_interp ) THEN !== s- or mixed s-zps-coordinate ==! ! - IF( kt == nit000 .AND. lwp )THEN - WRITE(numout,*) - WRITE(numout,*) 'dta_tsd: interpolates T & S data onto current mesh' + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 .AND. lwp )THEN + WRITE(numout,*) + WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the current mesh' + ENDIF ENDIF - DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points - DO jj= 1, jpj - DO ji= 1, jpi - zl = gdept_0(ji,jj,jk) - IF( zl < sf_tsd(jp_dep)%fnow(ji,jj,1) ) THEN ! above the first level of data - ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,1) - ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,1) - ELSEIF( zl > sf_tsd(jp_dep)%fnow(ji,jj,jpk_init) ) THEN ! below the last level of data - ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,jpk_init) - ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,jpk_init) - ELSE ! inbetween : vertical interpolation between jk_init & jk_init+1 - DO jk_init = 1, jpk_init-1 ! when gdept(jk_init) < zl < gdept(jk_init+1) - IF( sf_tsd(jp_msk)%fnow(ji,jj,jk_init+1) == 0 ) THEN ! if there is no data fill down + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! vertical interpolation of T & S + DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points + zl = gdept_0(ji,jj,jk) + IF( zl < sf_tsd(jp_dep)%fnow(ji,jj,1) ) THEN ! above the first level of data + ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,1) + ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,1) + ELSEIF( zl > sf_tsd(jp_dep)%fnow(ji,jj,jpk_init) ) THEN ! below the last level of data + ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,jpk_init) + ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,jpk_init) + ELSE ! inbetween : vertical interpolation between jkk & jkk+1 + DO jk_init = 1, jpk_init-1 ! when gdept(jkk) < zl < gdept(jkk+1) + IF( sf_tsd(jp_msk)%fnow(ji,jj,jk_init+1) == 0 ) THEN ! if there is no data fill down sf_tsd(jp_tem)%fnow(ji,jj,jk_init+1) = sf_tsd(jp_tem)%fnow(ji,jj,jk_init) sf_tsd(jp_sal)%fnow(ji,jj,jk_init+1) = sf_tsd(jp_sal)%fnow(ji,jj,jk_init) - ENDIF - IF( (zl-sf_tsd(jp_dep)%fnow(ji,jj,jk_init)) * (zl-sf_tsd(jp_dep)%fnow(ji,jj,jk_init+1)) <= 0._wp ) THEN + ENDIF + IF( (zl-sf_tsd(jp_dep)%fnow(ji,jj,jk_init)) * (zl-sf_tsd(jp_dep)%fnow(ji,jj,jk_init+1)) <= 0._wp ) THEN zi = ( zl - sf_tsd(jp_dep)%fnow(ji,jj,jk_init) ) / & & (sf_tsd(jp_dep)%fnow(ji,jj,jk_init+1)-sf_tsd(jp_dep)%fnow(ji,jj,jk_init)) ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,jk_init) + & & (sf_tsd(jp_tem)%fnow(ji,jj,jk_init+1)-sf_tsd(jp_tem)%fnow(ji,jj,jk_init)) * zi ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,jk_init) + & & (sf_tsd(jp_sal)%fnow(ji,jj,jk_init+1)-sf_tsd(jp_sal)%fnow(ji,jj,jk_init)) * zi - ENDIF - END DO - ENDIF - ENDDO - ENDDO - END DO + ENDIF + END DO + ENDIF + END DO + DO jk = 1, jpkm1 + ptsd(ji,jj,jk,jp_tem) = ptsd(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) ! mask required for mixed zps-s-coord + ptsd(ji,jj,jk,jp_sal) = ptsd(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) + END DO + ptsd(ji,jj,jpk,jp_tem) = 0._wp + ptsd(ji,jj,jpk,jp_sal) = 0._wp + END_2D + ! + ELSE !== z- or zps- coordinate ==! ! - ptsd(:,:,:,jp_tem) = ptsd(:,:,:,jp_tem) *tmask(:,:,:) - ptsd(:,:,:,jp_sal) = ptsd(:,:,:,jp_sal) *tmask(:,:,:) - ELSE + ! We must keep this definition in a case different from the general case of s-coordinate as we don't + ! want to use "underground" values (levels below ocean bottom) to be able to start the model from + ! masked temp and sal (read for example in a restart or in output.init) ! - CALL ctl_warn('dta_tsd: T & S data are assumed to be on the current mesh. No interpolation performed') - ! - ptsd(:,:,:,jp_tem) = sf_tsd(jp_tem)%fnow(:,:,:) * tmask(:,:,:) ! Mask - ptsd(:,:,:,jp_sal) = sf_tsd(jp_sal)%fnow(:,:,:) * tmask(:,:,:) + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) + ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,jk) * tmask(ji,jj,jk) + ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,jk) * tmask(ji,jj,jk) + END_3D ! IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level - DO jj = 1, jpj - DO ji = 1, jpi - ik = mbkt(ji,jj) - IF( ik > 1 ) THEN - zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) - ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik-1,jp_tem) - ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik-1,jp_sal) - ENDIF - ik = mikt(ji,jj) - IF( ik > 1 ) THEN - zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) - ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik+1,jp_tem) - ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik+1,jp_sal) - END IF - END DO - END DO + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ik = mbkt(ji,jj) + IF( ik > 1 ) THEN + zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) + ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik-1,jp_tem) + ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik-1,jp_sal) + ENDIF + ik = mikt(ji,jj) + IF( ik > 1 ) THEN + zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) + ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik+1,jp_tem) + ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik+1,jp_sal) + END IF + END_2D ENDIF ! ENDIF ! - IF( .NOT.ln_tsd_dmp ) THEN !== deallocate T & S structure ==! + IF( .NOT.ln_tsd_dmp ) THEN !== deallocate T & S structure ==! ! (data used only for initialisation) IF(lwp) WRITE(numout,*) 'dta_tsd: deallocte T & S arrays as they are only use to initialize the run' DEALLOCATE( sf_tsd(jp_tem)%fnow ) ! T arrays in the structure diff --git a/MY_SRC/icerst.F90 b/MY_SRC/icerst.F90 index 505c2a1..1882a57 100644 --- a/MY_SRC/icerst.F90 +++ b/MY_SRC/icerst.F90 @@ -10,8 +10,8 @@ MODULE icerst !! 'key_si3' SI3 sea-ice model !!---------------------------------------------------------------------- !! ice_rst_opn : open restart file - !! ice_rst_write : write restart file - !! ice_rst_read : read restart file + !! ice_rst_write : write restart file + !! ice_rst_read : read restart file !!---------------------------------------------------------------------- USE ice ! sea-ice: variables USE dom_oce ! ocean domain @@ -19,7 +19,7 @@ MODULE icerst USE sbc_oce , ONLY : nn_fsbc, ln_cpl USE sbc_oce , ONLY : nn_components, jp_iam_sas ! SAS ss[st]_m init USE sbc_oce , ONLY : sst_m, sss_m ! SAS ss[st]_m init - USE oce , ONLY : tsn ! SAS ss[st]_m init + USE oce , ONLY : ts ! SAS ss[st]_m init USE eosbn2 , ONLY : l_useCT, eos_pt_from_ct ! SAS ss[st]_m init USE iceistate ! sea-ice: initial state USE icectl ! sea-ice: control @@ -38,7 +38,7 @@ MODULE icerst !!---------------------------------------------------------------------- !! NEMO/ICE 4.0 , NEMO Consortium (2018) - !! $Id: icerst.F90 13449 2020-09-03 14:40:10Z gsamson $ + !! $Id: icerst.F90 14239 2020-12-23 08:57:16Z smasson $ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -53,14 +53,15 @@ SUBROUTINE ice_rst_opn( kt ) ! CHARACTER(len=20) :: clkt ! ocean time-step define as a character CHARACTER(len=256) :: clname ! ice output restart file name - CHARACTER(len=256) :: clpath ! full path to ice output restart file + CHARACTER(len=256) :: clpath ! full path to ice output restart file + CHARACTER(LEN=52) :: clpname ! ocean output restart file name including prefix for AGRIF !!---------------------------------------------------------------------- ! IF( kt == nit000 ) lrst_ice = .FALSE. ! default definition IF( ln_rst_list .OR. nn_stock /= -1 ) THEN - ! in order to get better performances with NetCDF format, we open and define the ice restart file - ! one ice time step before writing the data (-> at nitrst - 2*nn_fsbc + 1), except if we write ice + ! in order to get better performances with NetCDF format, we open and define the ice restart file + ! one ice time step before writing the data (-> at nitrst - 2*nn_fsbc + 1), except if we write ice ! restart files every ice time step or if an ice restart file was writen at nitend - 2*nn_fsbc + 1 IF( kt == nitrst - 2*nn_fsbc + 1 .OR. nn_stock == nn_fsbc & & .OR. ( kt == nitend - nn_fsbc + 1 .AND. .NOT. lrst_ice ) ) THEN @@ -71,7 +72,7 @@ SUBROUTINE ice_rst_opn( kt ) ENDIF ! create the file clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_icerst_out) - clpath = TRIM(cn_icerst_outdir) + clpath = TRIM(cn_icerst_outdir) IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath)//'/' IF(lwp) THEN WRITE(numout,*) @@ -83,7 +84,23 @@ SUBROUTINE ice_rst_opn( kt ) ENDIF ENDIF ! - CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl ) + IF(.NOT.lwxios) THEN + CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) + ELSE +#if defined key_xios + cw_icerst_cxt = "rstwi_"//TRIM(ADJUSTL(clkt)) + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + clpname = clname + ELSE + clpname = TRIM(Agrif_CFixed())//"_"//clname + ENDIF + numriw = iom_xios_setid(TRIM(clpath)//TRIM(clpname)) + CALL iom_init( cw_icerst_cxt, kdid = numriw, ld_closedef = .FALSE. ) + CALL iom_swap( cxios_context ) +#else + CALL ctl_stop( 'Can not use XIOS in rst_opn' ) +#endif + ENDIF lrst_ice = .TRUE. ENDIF ENDIF @@ -114,15 +131,16 @@ SUBROUTINE ice_rst_write( kt ) IF( iter == nitrst ) THEN IF(lwp) WRITE(numout,*) IF(lwp) WRITE(numout,*) 'ice_rst_write : write ice restart file kt =', kt - IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' ENDIF ! Write in numriw (if iter == nitrst) - ! ------------------ + ! ------------------ ! ! calendar control - CALL iom_rstput( iter, nitrst, numriw, 'nn_fsbc', REAL( nn_fsbc, wp ) ) ! time-step + CALL iom_rstput( iter, nitrst, numriw, 'nn_fsbc', REAL( nn_fsbc, wp ) ) ! time-step CALL iom_rstput( iter, nitrst, numriw, 'kt_ice' , REAL( iter , wp ) ) ! date - CALL iom_delay_rst( 'WRITE', 'ICE', numriw ) ! save only ice delayed global communication variables + + IF(.NOT.lwxios) CALL iom_delay_rst( 'WRITE', 'ICE', numriw ) ! save only ice delayed global communication variables ! Prognostic variables CALL iom_rstput( iter, nitrst, numriw, 'v_i' , v_i ) @@ -137,14 +155,14 @@ SUBROUTINE ice_rst_write( kt ) CALL iom_rstput( iter, nitrst, numriw, 'v_ip' , v_ip ) CALL iom_rstput( iter, nitrst, numriw, 'v_il' , v_il ) ! Snow enthalpy - DO jk = 1, nlay_s + DO jk = 1, nlay_s WRITE(zchar1,'(I2.2)') jk znam = 'e_s'//'_l'//zchar1 z3d(:,:,:) = e_s(:,:,jk,:) CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) END DO ! Ice enthalpy - DO jk = 1, nlay_i + DO jk = 1, nlay_i WRITE(zchar1,'(I2.2)') jk znam = 'e_i'//'_l'//zchar1 z3d(:,:,:) = e_i(:,:,jk,:) @@ -153,32 +171,40 @@ SUBROUTINE ice_rst_write( kt ) ! fields needed for Met Office (Jules) coupling IF( ln_cpl ) THEN CALL iom_rstput( iter, nitrst, numriw, 'cnd_ice', cnd_ice ) - CALL iom_rstput( iter, nitrst, numriw, 't1_ice' , t1_ice ) + CALL iom_rstput( iter, nitrst, numriw, 't1_ice' , t1_ice ) ENDIF ! ! close restart file ! ------------------ IF( iter == nitrst ) THEN - CALL iom_close( numriw ) + IF(.NOT.lwxios) THEN + CALL iom_close( numriw ) + ELSE + CALL iom_context_finalize( cw_icerst_cxt ) + iom_file(numriw)%nfid = 0 + numriw = 0 + ENDIF lrst_ice = .FALSE. ENDIF ! END SUBROUTINE ice_rst_write - SUBROUTINE ice_rst_read + SUBROUTINE ice_rst_read( Kbb, Kmm, Kaa ) !!---------------------------------------------------------------------- !! *** ice_rst_read *** !! !! ** purpose : read restart file !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices INTEGER :: jk LOGICAL :: llok INTEGER :: id0, id1, id2, id3, id4, id5 ! local integer CHARACTER(len=25) :: znam CHARACTER(len=2) :: zchar, zchar1 REAL(wp) :: zfice, ziter + CHARACTER(lc) :: clpname REAL(wp), DIMENSION(jpi,jpj,jpl) :: z3d ! 3D workspace !!---------------------------------------------------------------------- @@ -188,18 +214,29 @@ SUBROUTINE ice_rst_read WRITE(numout,*) '~~~~~~~~~~~~' ENDIF - CALL iom_open ( TRIM(cn_icerst_indir)//'/'//cn_icerst_in, numrir, kdlev = jpl ) + lxios_sini = .FALSE. + CALL iom_open ( TRIM(cn_icerst_indir)//'/'//cn_icerst_in, numrir ) - ! test if v_i exists + IF( lrxios) THEN + cr_icerst_cxt = 'si3_rst' + IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for SI3' +! IF( TRIM(Agrif_CFixed()) == '0' ) THEN +! clpname = cn_icerst_in +! ELSE +! clpname = TRIM(Agrif_CFixed())//"_"//cn_icerst_in +! ENDIF + CALL iom_init( cr_icerst_cxt, kdid = numrir, ld_closedef = .TRUE. ) + ENDIF + + ! test if v_i exists id0 = iom_varid( numrir, 'v_i' , ldstop = .FALSE. ) ! ! ------------------------------ ! IF( id0 > 0 ) THEN ! == case of a normal restart == ! ! ! ------------------------------ ! - ! Time info CALL iom_get( numrir, 'nn_fsbc', zfice ) - CALL iom_get( numrir, 'kt_ice' , ziter ) + CALL iom_get( numrir, 'kt_ice' , ziter ) IF(lwp) WRITE(numout,*) ' read ice restart file at time step : ', ziter IF(lwp) WRITE(numout,*) ' in any case we force it to nit000 - 1 : ', nit000 - 1 @@ -213,33 +250,33 @@ SUBROUTINE ice_rst_read & ' verify the file or rerun with the value 0 for the', & & ' control of time parameter nrstdt' ) - ! --- mandatory fields --- ! - CALL iom_get( numrir, jpdom_autoglo, 'v_i' , v_i ) - CALL iom_get( numrir, jpdom_autoglo, 'v_s' , v_s ) - CALL iom_get( numrir, jpdom_autoglo, 'sv_i' , sv_i ) - CALL iom_get( numrir, jpdom_autoglo, 'a_i' , a_i ) - CALL iom_get( numrir, jpdom_autoglo, 't_su' , t_su ) - CALL iom_get( numrir, jpdom_autoglo, 'u_ice', u_ice ) - CALL iom_get( numrir, jpdom_autoglo, 'v_ice', v_ice ) + ! --- mandatory fields --- ! + CALL iom_get( numrir, jpdom_auto, 'v_i' , v_i ) + CALL iom_get( numrir, jpdom_auto, 'v_s' , v_s ) + CALL iom_get( numrir, jpdom_auto, 'sv_i' , sv_i ) + CALL iom_get( numrir, jpdom_auto, 'a_i' , a_i ) + CALL iom_get( numrir, jpdom_auto, 't_su' , t_su ) + CALL iom_get( numrir, jpdom_auto, 'u_ice', u_ice, cd_type = 'U', psgn = -1._wp ) + CALL iom_get( numrir, jpdom_auto, 'v_ice', v_ice, cd_type = 'V', psgn = -1._wp ) ! Snow enthalpy DO jk = 1, nlay_s WRITE(zchar1,'(I2.2)') jk znam = 'e_s'//'_l'//zchar1 - CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) + CALL iom_get( numrir, jpdom_auto, znam , z3d ) e_s(:,:,jk,:) = z3d(:,:,:) END DO ! Ice enthalpy DO jk = 1, nlay_i WRITE(zchar1,'(I2.2)') jk znam = 'e_i'//'_l'//zchar1 - CALL iom_get( numrir, jpdom_autoglo, znam , z3d ) + CALL iom_get( numrir, jpdom_auto, znam , z3d ) e_i(:,:,jk,:) = z3d(:,:,:) END DO ! -- optional fields -- ! ! ice age id1 = iom_varid( numrir, 'oa_i' , ldstop = .FALSE. ) IF( id1 > 0 ) THEN ! fields exist - CALL iom_get( numrir, jpdom_autoglo, 'oa_i', oa_i ) + CALL iom_get( numrir, jpdom_auto, 'oa_i', oa_i ) ELSE ! start from rest IF(lwp) WRITE(numout,*) ' ==>> previous run without ice age output then set it to zero' oa_i(:,:,:) = 0._wp @@ -247,8 +284,8 @@ SUBROUTINE ice_rst_read ! melt ponds id2 = iom_varid( numrir, 'a_ip' , ldstop = .FALSE. ) IF( id2 > 0 ) THEN ! fields exist - CALL iom_get( numrir, jpdom_autoglo, 'a_ip' , a_ip ) - CALL iom_get( numrir, jpdom_autoglo, 'v_ip' , v_ip ) + CALL iom_get( numrir, jpdom_auto, 'a_ip' , a_ip ) + CALL iom_get( numrir, jpdom_auto, 'v_ip' , v_ip ) ELSE ! start from rest IF(lwp) WRITE(numout,*) ' ==>> previous run without melt ponds output then set it to zero' a_ip(:,:,:) = 0._wp @@ -257,7 +294,7 @@ SUBROUTINE ice_rst_read ! melt pond lids id3 = iom_varid( numrir, 'v_il' , ldstop = .FALSE. ) IF( id3 > 0 ) THEN - CALL iom_get( numrir, jpdom_autoglo, 'v_il', v_il) + CALL iom_get( numrir, jpdom_auto, 'v_il', v_il) ELSE IF(lwp) WRITE(numout,*) ' ==>> previous run without melt ponds lids output then set it to zero' v_il(:,:,:) = 0._wp @@ -267,8 +304,8 @@ SUBROUTINE ice_rst_read id4 = iom_varid( numrir, 'cnd_ice' , ldstop = .FALSE. ) id5 = iom_varid( numrir, 't1_ice' , ldstop = .FALSE. ) IF( id4 > 0 .AND. id5 > 0 ) THEN ! fields exist - CALL iom_get( numrir, jpdom_autoglo, 'cnd_ice', cnd_ice ) - CALL iom_get( numrir, jpdom_autoglo, 't1_ice' , t1_ice ) + CALL iom_get( numrir, jpdom_auto, 'cnd_ice', cnd_ice ) + CALL iom_get( numrir, jpdom_auto, 't1_ice' , t1_ice ) ELSE ! start from rest IF(lwp) WRITE(numout,*) ' ==>> previous run without conductivity output then set it to zero' cnd_ice(:,:,:) = 0._wp @@ -276,8 +313,7 @@ SUBROUTINE ice_rst_read ENDIF ENDIF - CALL iom_delay_rst( 'READ', 'ICE', numrir ) ! read only ice delayed global communication variables - + IF(.NOT.lrxios) CALL iom_delay_rst( 'READ', 'ICE', numrir ) ! read only ice delayed global communication variables ! ! ---------------------------------- ! ELSE ! == case of a simplified restart == ! ! ! ---------------------------------- ! @@ -292,13 +328,13 @@ SUBROUTINE ice_rst_read IF( nn_components == jp_iam_sas ) THEN ! SAS case: ss[st]_m were not initialized by sbc_ssm_init ! IF(lwp) WRITE(numout,*) ' SAS: default initialisation of ss[st]_m arrays used in ice_istate' - IF( l_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) - ELSE ; sst_m(:,:) = tsn(:,:,1,jp_tem) + IF( l_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( ts(:,:,1,jp_tem, Kmm), ts(:,:,1,jp_sal, Kmm) ) + ELSE ; sst_m(:,:) = ts(:,:,1,jp_tem, Kmm) ENDIF - sss_m(:,:) = tsn(:,:,1,jp_sal) + sss_m(:,:) = ts(:,:,1,jp_sal, Kmm) ENDIF ! - CALL ice_istate( nit000 ) + CALL ice_istate( nit000, Kbb, Kmm, Kaa ) ! ENDIF diff --git a/MY_SRC/in_out_manager.F90 b/MY_SRC/in_out_manager.F90 index c2b3f29..887ce52 100755 --- a/MY_SRC/in_out_manager.F90 +++ b/MY_SRC/in_out_manager.F90 @@ -1,4 +1,4 @@ -MODULE in_out_manager +MODULE in_out_manager !!====================================================================== !! *** MODULE in_out_manager *** !! I/O manager utilities : Defines run parameters together with logical units @@ -53,16 +53,16 @@ MODULE in_out_manager !!---------------------------------------------------------------------- ! The following four values determine the partitioning of the output fields ! into netcdf4 chunks. They are unrelated to the nn_chunk_sz setting which is - ! for runtime optimisation. The individual netcdf4 chunks can be optionally - ! gzipped (recommended) leading to significant reductions in I/O volumes + ! for runtime optimisation. The individual netcdf4 chunks can be optionally + ! gzipped (recommended) leading to significant reductions in I/O volumes ! !!!** variables only used with iom_nf90 routines and key_netcdf4 ** - INTEGER :: nn_nchunks_i !: number of chunks required in the i-dimension - INTEGER :: nn_nchunks_j !: number of chunks required in the j-dimension - INTEGER :: nn_nchunks_k !: number of chunks required in the k-dimension - INTEGER :: nn_nchunks_t !: number of chunks required in the t-dimension + INTEGER :: nn_nchunks_i !: number of chunks required in the i-dimension + INTEGER :: nn_nchunks_j !: number of chunks required in the j-dimension + INTEGER :: nn_nchunks_k !: number of chunks required in the k-dimension + INTEGER :: nn_nchunks_t !: number of chunks required in the t-dimension LOGICAL :: ln_nc4zip !: netcdf4 usage: (T) chunk and compress output using the HDF5 sublayers of netcdf4 - ! ! (F) ignore chunking request and use the netcdf4 library - ! ! to produce netcdf3-compatible files + ! ! (F) ignore chunking request and use the netcdf4 library + ! ! to produce netcdf3-compatible files #endif !$AGRIF_DO_NOT_TREAT @@ -85,29 +85,33 @@ MODULE in_out_manager !! was in restart but moved here because of the OFF line... better solution should be found... !!---------------------------------------------------------------------- INTEGER :: nitrst !: time step at which restart file should be written - LOGICAL :: lrst_oce !: logical to control the oce restart write - LOGICAL :: lrst_ice !: logical to control the ice restart write + LOGICAL :: lrst_oce !: logical to control the oce restart write + LOGICAL :: lrst_ice !: logical to control the ice restart write + LOGICAL :: lrst_abl !: logical to control the abl restart write INTEGER :: numror = 0 !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) - INTEGER :: numrir !: logical unit for ice restart (read) - INTEGER :: numrow !: logical unit for ocean restart (write) - INTEGER :: numriw !: logical unit for ice restart (write) + INTEGER :: numrir = 0 !: logical unit for ice restart (read) + INTEGER :: numrar = 0 !: logical unit for abl restart (read) + INTEGER :: numrow = 0 !: logical unit for ocean restart (write) + INTEGER :: numriw = 0 !: logical unit for ice restart (write) + INTEGER :: numraw = 0 !: logical unit for abl restart (write) + INTEGER :: numrtr = 0 !: trc restart (read ) + INTEGER :: numrtw = 0 !: trc restart (write ) + INTEGER :: numrsr = 0 !: logical unit for sed restart (read) + INTEGER :: numrsw = 0 !: logical unit for sed restart (write) + INTEGER :: nrst_lst !: number of restart to output next !!---------------------------------------------------------------------- !! output monitoring !!---------------------------------------------------------------------- - LOGICAL :: ln_ctl !: run control for debugging - TYPE :: sn_ctl !: optional use structure for finer control over output selection - LOGICAL :: l_config = .FALSE. !: activate/deactivate finer control - ! Note if l_config is True then ln_ctl is ignored. - ! Otherwise setting ln_ctl True is equivalent to setting - ! all the following logicals in this structure True + TYPE :: sn_ctl !: structure for control over output selection LOGICAL :: l_runstat = .FALSE. !: Produce/do not produce run.stat file (T/F) LOGICAL :: l_trcstat = .FALSE. !: Produce/do not produce tracer.stat file (T/F) LOGICAL :: l_oceout = .FALSE. !: Produce all ocean.outputs (T) or just one (F) LOGICAL :: l_layout = .FALSE. !: Produce all layout.dat files (T) or just one (F) - LOGICAL :: l_mppout = .FALSE. !: Produce/do not produce mpp.output_XXXX files (T/F) - LOGICAL :: l_mpptop = .FALSE. !: Produce/do not produce mpp.top.output_XXXX files (T/F) + LOGICAL :: l_prtctl = .FALSE. !: Produce/do not produce mpp.output_XXXX files (T/F) + LOGICAL :: l_prttrc = .FALSE. !: Produce/do not produce mpp.top.output_XXXX files (T/F) + LOGICAL :: l_oasout = .FALSE. !: Produce/do not write oasis setup info to ocean.output (T/F) ! Optional subsetting of processor report files ! Default settings of 0/1000000/1 should ensure all areas report. ! Set to a more restrictive range to select specific areas @@ -119,17 +123,12 @@ MODULE in_out_manager TYPE(sn_ctl), SAVE :: sn_cfctl !: run control structure for selective output, must have SAVE for default init. of sn_ctl LOGICAL :: ln_timing !: run control for timing LOGICAL :: ln_diacfl !: flag whether to create CFL diagnostics - INTEGER :: nn_print !: level of print (0 no print) INTEGER :: nn_ictls !: Start i indice for the SUM control INTEGER :: nn_ictle !: End i indice for the SUM control INTEGER :: nn_jctls !: Start j indice for the SUM control INTEGER :: nn_jctle !: End j indice for the SUM control INTEGER :: nn_isplt !: number of processors following i INTEGER :: nn_jsplt !: number of processors following j - ! - INTEGER :: nprint, nictls, nictle, njctls, njctle, isplt, jsplt !: OLD namelist names - - INTEGER :: ijsplt = 1 !: nb of local domain = nb of processors !!---------------------------------------------------------------------- !! logical units @@ -139,23 +138,24 @@ MODULE in_out_manager INTEGER :: numout = 6 !: logical unit for output print; Set to stdout to ensure any INTEGER :: numnul = -1 !: logical unit for /dev/null ! ! early output can be collected; do not change - INTEGER :: numnam_ref = -1 !: logical unit for reference namelist - INTEGER :: numnam_cfg = -1 !: logical unit for configuration specific namelist INTEGER :: numond = -1 !: logical unit for Output Namelist Dynamics - INTEGER :: numnam_ice_ref = -1 !: logical unit for ice reference namelist - INTEGER :: numnam_ice_cfg = -1 !: logical unit for ice reference namelist INTEGER :: numoni = -1 !: logical unit for Output Namelist Ice INTEGER :: numevo_ice = -1 !: logical unit for ice variables (temp. evolution) INTEGER :: numrun = -1 !: logical unit for run statistics INTEGER :: numdct_in = -1 !: logical unit for transports computing - INTEGER :: numdct_vol = -1 !: logical unit for voulume transports output - INTEGER :: numdct_heat = -1 !: logical unit for heat transports output - INTEGER :: numdct_salt = -1 !: logical unit for salt transports output + INTEGER :: numdct_vol = -1 !: logical unit for volume transports output + INTEGER :: numdct_heat = -1 !: logical unit for heat transports output + INTEGER :: numdct_salt = -1 !: logical unit for salt transports output INTEGER :: numfl = -1 !: logical unit for floats ascii output INTEGER :: numflo = -1 !: logical unit for floats ascii output + ! + CHARACTER(LEN=:), ALLOCATABLE :: numnam_ref !: character buffer for reference namelist + CHARACTER(LEN=:), ALLOCATABLE :: numnam_cfg !: character buffer for configuration specific namelist + CHARACTER(LEN=:), ALLOCATABLE :: numnam_ice_ref !: character buffer for ice reference namelist + CHARACTER(LEN=:), ALLOCATABLE :: numnam_ice_cfg !: character buffer for ice configuration specific namelist !!---------------------------------------------------------------------- - !! Run control + !! Run control !!---------------------------------------------------------------------- INTEGER :: no_print = 0 !: optional argument of fld_fill (if present, suppress some control print) INTEGER :: nstop = 0 !: error flag (=number of reason for a premature stop run) @@ -168,15 +168,28 @@ MODULE in_out_manager CHARACTER(lc) :: ctmp7, ctmp8, ctmp9 !: temporary characters 7 to 9 CHARACTER(lc) :: ctmp10 !: temporary character 10 LOGICAL :: lwm = .FALSE. !: boolean : true on the 1st processor only (always) - LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only .OR. ln_ctl + LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only .OR. sn_cfctl%l_oceout=T LOGICAL :: lsp_area = .TRUE. !: to make a control print over a specific area - CHARACTER(lc) :: cxios_context !: context name used in xios - CHARACTER(lc) :: crxios_context !: context name used in xios to read restart - CHARACTER(lc) :: cwxios_context !: context name used in xios to write restart file + CHARACTER(LEN=lc) :: cxios_context !: context name used in xios + CHARACTER(LEN=lc) :: cr_ocerst_cxt !: context name used in xios to read OCE restart + CHARACTER(LEN=lc) :: cw_ocerst_cxt !: context name used in xios to write OCE restart file + CHARACTER(LEN=lc) :: cr_icerst_cxt !: context name used in xios to read SI3 restart + CHARACTER(LEN=lc) :: cw_icerst_cxt !: context name used in xios to write SI3 restart file + CHARACTER(LEN=lc) :: cr_ablrst_cxt !: context name used in xios to read ABL restart + CHARACTER(LEN=lc) :: cw_ablrst_cxt !: context name used in xios to write ABL restart file + CHARACTER(LEN=lc) :: cr_toprst_cxt !: context name used in xios to read TOP restart + CHARACTER(LEN=lc) :: cw_toprst_cxt !: context name used in xios to write TOP restart file + CHARACTER(LEN=lc) :: cr_sedrst_cxt !: context name used in xios to read SEDIMENT restart + CHARACTER(LEN=lc) :: cw_sedrst_cxt !: context name used in xios to write SEDIMENT restart file + + + + !! * Substitutions +# include "do_loop_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: in_out_manager.F90 12859 2020-05-03 09:33:32Z smasson $ + !! $Id: in_out_manager.F90 14553 2021-02-26 17:01:43Z gsamson $ !! Software governed by the CeCILL license (see ./LICENSE) !!===================================================================== END MODULE in_out_manager diff --git a/MY_SRC/istate.F90 b/MY_SRC/istate.F90 deleted file mode 100755 index 03d917a..0000000 --- a/MY_SRC/istate.F90 +++ /dev/null @@ -1,182 +0,0 @@ -MODULE istate - !!====================================================================== - !! *** MODULE istate *** - !! Ocean state : initial state setting - !!===================================================================== - !! History : OPA ! 1989-12 (P. Andrich) Original code - !! 5.0 ! 1991-11 (G. Madec) rewritting - !! 6.0 ! 1996-01 (G. Madec) terrain following coordinates - !! 8.0 ! 2001-09 (M. Levy, M. Ben Jelloul) istate_eel - !! 8.0 ! 2001-09 (M. Levy, M. Ben Jelloul) istate_uvg - !! NEMO 1.0 ! 2003-08 (G. Madec, C. Talandier) F90: Free form, modules + EEL R5 - !! - ! 2004-05 (A. Koch-Larrouy) istate_gyre - !! 2.0 ! 2006-07 (S. Masson) distributed restart using iom - !! 3.3 ! 2010-10 (C. Ethe) merge TRC-TRA - !! 3.4 ! 2011-04 (G. Madec) Merge of dtatem and dtasal & suppression of tb,tn/sb,sn - !! 3.7 ! 2016-04 (S. Flavoni) introduce user defined initial state - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! istate_init : initial state setting - !! istate_uvg : initial velocity in geostropic balance - !!---------------------------------------------------------------------- - USE oce ! ocean dynamics and active tracers - USE dom_oce ! ocean space and time domain - USE daymod ! calendar - USE dtatsd ! data temperature and salinity (dta_tsd routine) - USE dtauvd ! data: U & V current (dta_uvd routine) - USE domvvl ! varying vertical mesh - USE iscplrst ! ice sheet coupling - USE wet_dry ! wetting and drying (needed for wad_istate) - USE usrdef_istate ! User defined initial state - ! - USE in_out_manager ! I/O manager - USE iom ! I/O library - USE lib_mpp ! MPP library - USE restart ! restart - - IMPLICIT NONE - PRIVATE - - PUBLIC istate_init ! routine called by step.F90 - - !! * Substitutions -# include "vectopt_loop_substitute.h90" - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: istate.F90 13101 2020-06-12 11:10:44Z rblod $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE istate_init - !!---------------------------------------------------------------------- - !! *** ROUTINE istate_init *** - !! - !! ** Purpose : Initialization of the dynamics and tracer fields. - !!---------------------------------------------------------------------- - INTEGER :: ji, jj, jk ! dummy loop indices -!!gm see comment further down - REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace -!!gm end - !!---------------------------------------------------------------------- - ! - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'istate_init : Initialization of the dynamics and tracers' - IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' - - CALL day_init ! need this to read initial conditions with interpolation - -!!gm Why not include in the first call of dta_tsd ? -!!gm probably associated with the use of internal damping... - CALL dta_tsd_init ! Initialisation of T & S input data -!!gm to be moved in usrdef of C1D case -! IF( lk_c1d ) CALL dta_uvd_init ! Initialization of U & V input data -!!gm - - rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk - rn2b (:,:,: ) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk - tsa (:,:,:,:) = 0._wp ! set one for all to 0 at level jpk - rab_b(:,:,:,:) = 0._wp ; rab_n(:,:,:,:) = 0._wp ! set one for all to 0 at level jpk -#if defined key_agrif - ua (:,:,: ) = 0._wp ! used in agrif_oce_sponge at initialization - va (:,:,: ) = 0._wp ! used in agrif_oce_sponge at initialization -#endif - - IF( ln_rstart ) THEN ! Restart from a file - ! ! ------------------- - CALL rst_read ! Read the restart file - IF (ln_iscpl) CALL iscpl_stp ! extrapolate restart to wet and dry - CALL day_init ! model calendar (using both namelist and restart infos) - ! - ELSE ! Start from rest - ! ! --------------- - numror = 0 ! define numror = 0 -> no restart file to read - neuler = 0 ! Set time-step indicator at nit000 (euler forward) - CALL day_init ! model calendar (using both namelist and restart infos) - ! ! Initialization of ocean to zero - ! - IF( ln_tsd_init ) THEN - CALL dta_tsd( nit000, tsb ) ! read 3D T and S data at nit000 - ! - sshb(:,:) = 0._wp ! set the ocean at rest - IF( ll_wd ) THEN - sshb(:,:) = -ssh_ref ! Added in 30 here for bathy that adds 30 as Iterative test CEOD - ! - ! Apply minimum wetdepth criterion - ! - DO jj = 1,jpj - DO ji = 1,jpi - IF( ht_0(ji,jj) + sshb(ji,jj) < rn_wdmin1 ) THEN - sshb(ji,jj) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) ) - ENDIF - END DO - END DO - ENDIF - ub (:,:,:) = 0._wp - vb (:,:,:) = 0._wp - ! - ELSE ! user defined initial T and S - CALL usr_def_istate( gdept_b, tmask, tsb, ub, vb, sshb ) - ENDIF - tsn (:,:,:,:) = tsb (:,:,:,:) ! set now values from to before ones - sshn (:,:) = sshb(:,:) - un (:,:,:) = ub (:,:,:) - vn (:,:,:) = vb (:,:,:) - -!!gm POTENTIAL BUG : -!!gm ISSUE : if sshb /= 0 then, in non linear free surface, the e3._n, e3._b should be recomputed -!! as well as gdept and gdepw.... !!!!! -!! ===>>>> probably a call to domvvl initialisation here.... - - - ! -!!gm to be moved in usrdef of C1D case -! IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000 -! ALLOCATE( zuvd(jpi,jpj,jpk,2) ) -! CALL dta_uvd( nit000, zuvd ) -! ub(:,:,:) = zuvd(:,:,:,1) ; un(:,:,:) = ub(:,:,:) -! vb(:,:,:) = zuvd(:,:,:,2) ; vn(:,:,:) = vb(:,:,:) -! DEALLOCATE( zuvd ) -! ENDIF - ! -!!gm This is to be changed !!!! -! ! - ML - sshn could be modified by istate_eel, so that initialization of e3t_b is done here -! IF( .NOT.ln_linssh ) THEN -! DO jk = 1, jpk -! e3t_b(:,:,jk) = e3t_n(:,:,jk) -! END DO -! ENDIF -!!gm - ! - ENDIF - ! - ! Initialize "now" and "before" barotropic velocities: - ! Do it whatever the free surface method, these arrays being eventually used - ! - un_b(:,:) = 0._wp ; vn_b(:,:) = 0._wp - ub_b(:,:) = 0._wp ; vb_b(:,:) = 0._wp - ! -!!gm the use of umsak & vmask is not necessary below as un, vn, ub, vb are always masked - DO jk = 1, jpkm1 - DO jj = 1, jpj - DO ji = 1, jpi - un_b(ji,jj) = un_b(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk) * umask(ji,jj,jk) - vn_b(ji,jj) = vn_b(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk) * vmask(ji,jj,jk) - ! - ub_b(ji,jj) = ub_b(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk) * umask(ji,jj,jk) - vb_b(ji,jj) = vb_b(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk) * vmask(ji,jj,jk) - END DO - END DO - END DO - ! - un_b(:,:) = un_b(:,:) * r1_hu_n(:,:) - vn_b(:,:) = vn_b(:,:) * r1_hv_n(:,:) - ! - ub_b(:,:) = ub_b(:,:) * r1_hu_b(:,:) - vb_b(:,:) = vb_b(:,:) * r1_hv_b(:,:) - ! - END SUBROUTINE istate_init - - !!====================================================================== -END MODULE istate diff --git a/MY_SRC/par_oce.F90 b/MY_SRC/par_oce.F90 index c596328..ea08e9f 100755 --- a/MY_SRC/par_oce.F90 +++ b/MY_SRC/par_oce.F90 @@ -21,19 +21,23 @@ MODULE par_oce CHARACTER(lc) :: cn_domcfg_out !: filename the configuration file to be read ! LOGICAL :: ln_use_jattr !: input file read offset - ! ! Use file global attribute: open_ocean_jstart to determine start j-row - ! ! when reading input from those netcdf files that have the - ! ! attribute defined. This is designed to enable input files associated - ! ! with the extended grids used in the under ice shelf configurations to + ! ! Use file global attribute: open_ocean_jstart to determine start j-row + ! ! when reading input from those netcdf files that have the + ! ! attribute defined. This is designed to enable input files associated + ! ! with the extended grids used in the under ice shelf configurations to ! ! be used without redundant rows when the ice shelves are not in use. - ! + LOGICAL :: ln_closea !: (=T) special treatment of closed sea + ! !!--------------------------------------------------------------------- - !! Domain Matrix size + !! Domain Matrix size !!--------------------------------------------------------------------- ! configuration name & resolution (required only in ORCA family case) CHARACTER(lc) :: cn_cfg !: name of the configuration - INTEGER :: nn_cfg !: resolution of the configuration + INTEGER :: nn_cfg !: resolution of the configuration + + ! time dimension + INTEGER, PUBLIC, PARAMETER :: jpt = 3 !: time dimension ! global domain size !!! * total computational domain * INTEGER :: jpiglo !: 1st dimension of global domain --> i-direction @@ -42,20 +46,32 @@ MODULE par_oce ! global domain size for AGRIF !!! * total AGRIF computational domain * INTEGER, PUBLIC :: nbug_in_agrif_conv_do_not_remove_or_modify = 1 - 1 - INTEGER, PUBLIC, PARAMETER :: nbghostcells = 3 !: number of ghost cells - INTEGER, PUBLIC :: nbcellsx ! = jpiglo - 2 - 2*nbghostcells !: number of cells in i-direction - INTEGER, PUBLIC :: nbcellsy ! = jpjglo - 2 - 2*nbghostcells !: number of cells in j-direction + INTEGER, PUBLIC, PARAMETER :: nbghostcells = 4 !: number of ghost cells: default value + INTEGER, PUBLIC :: nbghostcells_x_w !: number of ghost cells in i-direction at west + INTEGER, PUBLIC :: nbghostcells_x_e !: number of ghost cells in i-direction at east + INTEGER, PUBLIC :: nbghostcells_y_s !: number of ghost cells in j-direction at south + INTEGER, PUBLIC :: nbghostcells_y_n !: number of ghost cells in j-direction at north + INTEGER, PUBLIC :: nbcellsx !: number of cells in i-direction + INTEGER, PUBLIC :: nbcellsy !: number of cells in j-direction ! local domain size !!! * local computational domain * INTEGER, PUBLIC :: jpi ! !: first dimension INTEGER, PUBLIC :: jpj ! !: second dimension INTEGER, PUBLIC :: jpk ! = jpkglo !: third dimension - INTEGER, PUBLIC :: jpim1 ! = jpi-1 !: inner domain indices - INTEGER, PUBLIC :: jpjm1 ! = jpj-1 !: - - - INTEGER, PUBLIC :: jpkm1 ! = jpk-1 !: - - - INTEGER, PUBLIC :: jpij ! = jpi*jpj !: jpi x jpj - INTEGER, PUBLIC :: jpimax! = ( jpiglo-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls !: maximum jpi - INTEGER, PUBLIC :: jpjmax! = ( jpjglo-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls !: maximum jpj + INTEGER, PUBLIC :: jpimax! = ( Ni0glo + jpni-1 ) / jpni + 2*nn_hls !: maximum jpi + INTEGER, PUBLIC :: jpjmax! = ( Nj0glo + jpnj-1 ) / jpnj + 2*nn_hls !: maximum jpj + + ! Domain tiling + INTEGER, PUBLIC :: nijtile !: number of tiles in total + INTEGER, PUBLIC :: ntile !: current tile number + INTEGER, PUBLIC :: ntsi !: start of internal part of tile domain + INTEGER, PUBLIC :: ntsj ! + INTEGER, PUBLIC :: ntei !: end of internal part of tile domain + INTEGER, PUBLIC :: ntej ! + INTEGER, PUBLIC :: nthl, nthr !: Modifier on DO loop macro bound offset (left, right) + INTEGER, PUBLIC :: nthb, ntht !: " " (bottom, top) !!--------------------------------------------------------------------- !! Active tracer parameters @@ -70,16 +86,24 @@ MODULE par_oce !! Domain decomposition !!---------------------------------------------------------------------- !! if we dont use massively parallel computer (parameters jpni=jpnj=1) so jpiglo=jpi and jpjglo=jpj - INTEGER, PUBLIC :: jpni !: number of processors following i + INTEGER, PUBLIC :: jpni !: number of processors following i INTEGER, PUBLIC :: jpnj !: number of processors following j INTEGER, PUBLIC :: jpnij !: nb of local domain = nb of processors ( <= jpni x jpnj ) - INTEGER, PUBLIC, PARAMETER :: jpr2di = 0 !: number of columns for extra outer halo - INTEGER, PUBLIC, PARAMETER :: jpr2dj = 0 !: number of rows for extra outer halo - INTEGER, PUBLIC, PARAMETER :: nn_hls = 1 !: halo width (applies to both rows and columns) + INTEGER, PUBLIC, PARAMETER :: jpr2di = 0 !: number of columns for extra outer halo + INTEGER, PUBLIC, PARAMETER :: jpr2dj = 0 !: number of rows for extra outer halo + + ! halo with and starting/inding DO-loop indices + INTEGER, PUBLIC :: nn_hls !: halo width (applies to both rows and columns) + INTEGER, PUBLIC :: Nis0 !: start I-index without halo + INTEGER, PUBLIC :: Nie0 !: end I-index without halo + INTEGER, PUBLIC :: Njs0 !: start J-index without halo + INTEGER, PUBLIC :: Nje0 !: end J-index without halo + INTEGER, PUBLIC :: Ni_0, Nj_0 !: local domain size without halo + INTEGER, PUBLIC :: Ni0glo, Nj0glo !: global domain size without halo !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: par_oce.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! $Id: par_oce.F90 15119 2021-07-13 14:43:22Z jchanut $ !! Software governed by the CeCILL license (see ./LICENSE) !!====================================================================== END MODULE par_oce diff --git a/MY_SRC/sbcblk.F90 b/MY_SRC/sbcblk.F90 deleted file mode 100755 index 1d7363d..0000000 --- a/MY_SRC/sbcblk.F90 +++ /dev/null @@ -1,1251 +0,0 @@ -MODULE sbcblk - !!====================================================================== - !! *** MODULE sbcblk *** - !! Ocean forcing: momentum, heat and freshwater flux formulation - !! Aerodynamic Bulk Formulas - !! SUCCESSOR OF "sbcblk_core" - !!===================================================================== - !! History : 1.0 ! 2004-08 (U. Schweckendiek) Original CORE code - !! 2.0 ! 2005-04 (L. Brodeau, A.M. Treguier) improved CORE bulk and its user interface - !! 3.0 ! 2006-06 (G. Madec) sbc rewritting - !! - ! 2006-12 (L. Brodeau) Original code for turb_core - !! 3.2 ! 2009-04 (B. Lemaire) Introduce iom_put - !! 3.3 ! 2010-10 (S. Masson) add diurnal cycle - !! 3.4 ! 2011-11 (C. Harris) Fill arrays required by CICE - !! 3.7 ! 2014-06 (L. Brodeau) simplification and optimization of CORE bulk - !! 4.0 ! 2016-06 (L. Brodeau) sbcblk_core becomes sbcblk and is not restricted to the CORE algorithm anymore - !! ! ==> based on AeroBulk (http://aerobulk.sourceforge.net/) - !! 4.0 ! 2016-10 (G. Madec) introduce a sbc_blk_init routine - !! 4.0 ! 2016-10 (M. Vancoppenolle) Introduce conduction flux emulator (M. Vancoppenolle) - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! sbc_blk_init : initialisation of the chosen bulk formulation as ocean surface boundary condition - !! sbc_blk : bulk formulation as ocean surface boundary condition - !! blk_oce : computes momentum, heat and freshwater fluxes over ocean - !! rho_air : density of (moist) air (depends on T_air, q_air and SLP - !! cp_air : specific heat of (moist) air (depends spec. hum. q_air) - !! q_sat : saturation humidity as a function of SLP and temperature - !! L_vap : latent heat of vaporization of water as a function of temperature - !! sea-ice case only : - !! blk_ice_tau : provide the air-ice stress - !! blk_ice_flx : provide the heat and mass fluxes at air-ice interface - !! blk_ice_qcn : provide ice surface temperature and snow/ice conduction flux (emulating conduction flux) - !! Cdn10_Lupkes2012 : Lupkes et al. (2012) air-ice drag - !! Cdn10_Lupkes2015 : Lupkes et al. (2015) air-ice drag - !!---------------------------------------------------------------------- - USE oce ! ocean dynamics and tracers - USE dom_oce ! ocean space and time domain - USE phycst ! physical constants - USE fldread ! read input fields - USE sbc_oce ! Surface boundary condition: ocean fields - USE cyclone ! Cyclone 10m wind form trac of cyclone centres - USE sbcdcy ! surface boundary condition: diurnal cycle - USE sbcwave , ONLY : cdn_wave ! wave module - USE sbc_ice ! Surface boundary condition: ice fields - USE lib_fortran ! to use key_nosignedzero -#if defined key_si3 - USE ice , ONLY : u_ice, v_ice, jpl, a_i_b, at_i_b, t_su, rn_cnd_s, hfx_err_dif, nn_qtrice - USE icevar ! for CALL ice_var_snwblow -#endif - USE sbcblk_algo_ncar ! => turb_ncar : NCAR - CORE (Large & Yeager, 2009) - USE sbcblk_algo_coare ! => turb_coare : COAREv3.0 (Fairall et al. 2003) - USE sbcblk_algo_coare3p5 ! => turb_coare3p5 : COAREv3.5 (Edson et al. 2013) - USE sbcblk_algo_ecmwf ! => turb_ecmwf : ECMWF (IFS cycle 31) - ! - USE iom ! I/O manager library - USE in_out_manager ! I/O manager - USE lib_mpp ! distribued memory computing library - USE lbclnk ! ocean lateral boundary conditions (or mpp link) - USE prtctl ! Print control - - IMPLICIT NONE - PRIVATE - - PUBLIC sbc_blk_init ! called in sbcmod - PUBLIC sbc_blk ! called in sbcmod -#if defined key_si3 - PUBLIC blk_ice_tau ! routine called in icesbc - PUBLIC blk_ice_flx ! routine called in icesbc - PUBLIC blk_ice_qcn ! routine called in icesbc -#endif - -!!Lolo: should ultimately be moved in the module with all physical constants ? -!!gm : In principle, yes. - REAL(wp), PARAMETER :: Cp_dry = 1005.0 !: Specic heat of dry air, constant pressure [J/K/kg] - REAL(wp), PARAMETER :: Cp_vap = 1860.0 !: Specic heat of water vapor, constant pressure [J/K/kg] - REAL(wp), PARAMETER :: R_dry = 287.05_wp !: Specific gas constant for dry air [J/K/kg] - REAL(wp), PARAMETER :: R_vap = 461.495_wp !: Specific gas constant for water vapor [J/K/kg] - REAL(wp), PARAMETER :: reps0 = R_dry/R_vap !: ratio of gas constant for dry air and water vapor => ~ 0.622 - REAL(wp), PARAMETER :: rctv0 = R_vap/R_dry - 1._wp !: for virtual temperature (== (1-eps)/eps) => ~ 0.608 - - INTEGER , PARAMETER :: jpfld =11 ! maximum number of files to read - INTEGER , PARAMETER :: jp_wndi = 1 ! index of 10m wind velocity (i-component) (m/s) at T-point - INTEGER , PARAMETER :: jp_wndj = 2 ! index of 10m wind velocity (j-component) (m/s) at T-point - INTEGER , PARAMETER :: jp_tair = 3 ! index of 10m air temperature (Kelvin) - INTEGER , PARAMETER :: jp_humi = 4 ! index of specific humidity ( % ) - INTEGER , PARAMETER :: jp_qsr = 5 ! index of solar heat (W/m2) - INTEGER , PARAMETER :: jp_qlw = 6 ! index of Long wave (W/m2) - INTEGER , PARAMETER :: jp_prec = 7 ! index of total precipitation (rain+snow) (Kg/m2/s) - INTEGER , PARAMETER :: jp_snow = 8 ! index of snow (solid prcipitation) (kg/m2/s) - INTEGER , PARAMETER :: jp_slp = 9 ! index of sea level pressure (Pa) - INTEGER , PARAMETER :: jp_cc =10 ! index of cloud cover (-) range:0-1 - INTEGER , PARAMETER :: jp_tdif =11 ! index of tau diff associated to HF tau (N/m2) at T-point - - TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read) - - ! !!! Bulk parameters - REAL(wp), PARAMETER :: cpa = 1000.5 ! specific heat of air (only used for ice fluxes now...) - REAL(wp), PARAMETER :: Ls = 2.839e6 ! latent heat of sublimation - REAL(wp), PARAMETER :: Stef = 5.67e-8 ! Stefan Boltzmann constant - REAL(wp), PARAMETER :: Cd_ice = 1.4e-3 ! transfer coefficient over ice - REAL(wp), PARAMETER :: albo = 0.066 ! ocean albedo assumed to be constant - ! - ! !!* Namelist namsbc_blk : bulk parameters - LOGICAL :: ln_NCAR ! "NCAR" algorithm (Large and Yeager 2008) - LOGICAL :: ln_COARE_3p0 ! "COARE 3.0" algorithm (Fairall et al. 2003) - LOGICAL :: ln_COARE_3p5 ! "COARE 3.5" algorithm (Edson et al. 2013) - LOGICAL :: ln_ECMWF ! "ECMWF" algorithm (IFS cycle 31) - ! - LOGICAL :: ln_taudif ! logical flag to use the "mean of stress module - module of mean stress" data - REAL(wp) :: rn_pfac ! multiplication factor for precipitation - REAL(wp) :: rn_efac ! multiplication factor for evaporation - REAL(wp) :: rn_vfac ! multiplication factor for ice/ocean velocity in the calculation of wind stress - REAL(wp) :: rn_zqt ! z(q,t) : height of humidity and temperature measurements - REAL(wp) :: rn_zu ! z(u) : height of wind measurements -!!gm ref namelist initialize it so remove the setting to false below - LOGICAL :: ln_Cd_L12 = .FALSE. ! Modify the drag ice-atm depending on ice concentration (from Lupkes et al. JGR2012) - LOGICAL :: ln_Cd_L15 = .FALSE. ! Modify the drag ice-atm depending on ice concentration (from Lupkes et al. JGR2015) - ! - REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: Cd_atm ! transfer coefficient for momentum (tau) - REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: Ch_atm ! transfer coefficient for sensible heat (Q_sens) - REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: Ce_atm ! tansfert coefficient for evaporation (Q_lat) - REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_zu ! air temperature at wind speed height (needed by Lupkes 2015 bulk scheme) - REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_zu ! air spec. hum. at wind speed height (needed by Lupkes 2015 bulk scheme) - REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: cdn_oce, chn_oce, cen_oce ! needed by Lupkes 2015 bulk scheme - - INTEGER :: nblk ! choice of the bulk algorithm - ! ! associated indices: - INTEGER, PARAMETER :: np_NCAR = 1 ! "NCAR" algorithm (Large and Yeager 2008) - INTEGER, PARAMETER :: np_COARE_3p0 = 2 ! "COARE 3.0" algorithm (Fairall et al. 2003) - INTEGER, PARAMETER :: np_COARE_3p5 = 3 ! "COARE 3.5" algorithm (Edson et al. 2013) - INTEGER, PARAMETER :: np_ECMWF = 4 ! "ECMWF" algorithm (IFS cycle 31) - - !! * Substitutions -# include "vectopt_loop_substitute.h90" - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: sbcblk.F90 13348 2020-07-27 16:55:57Z acc $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - INTEGER FUNCTION sbc_blk_alloc() - !!------------------------------------------------------------------- - !! *** ROUTINE sbc_blk_alloc *** - !!------------------------------------------------------------------- - ALLOCATE( Cd_atm (jpi,jpj), Ch_atm (jpi,jpj), Ce_atm (jpi,jpj), t_zu(jpi,jpj), q_zu(jpi,jpj), & - & cdn_oce(jpi,jpj), chn_oce(jpi,jpj), cen_oce(jpi,jpj), STAT=sbc_blk_alloc ) - ! - CALL mpp_sum ( 'sbcblk', sbc_blk_alloc ) - IF( sbc_blk_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_alloc: failed to allocate arrays' ) - END FUNCTION sbc_blk_alloc - - - SUBROUTINE sbc_blk_init - !!--------------------------------------------------------------------- - !! *** ROUTINE sbc_blk_init *** - !! - !! ** Purpose : choose and initialize a bulk formulae formulation - !! - !! ** Method : - !! - !!---------------------------------------------------------------------- - INTEGER :: jfpr, jfld ! dummy loop indice and argument - INTEGER :: ios, ierror, ioptio ! Local integer - !! - CHARACTER(len=100) :: cn_dir ! Root directory for location of atmospheric forcing files - TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist informations on the fields to read - TYPE(FLD_N) :: sn_wndi, sn_wndj, sn_humi, sn_qsr ! informations about the fields to be read - TYPE(FLD_N) :: sn_qlw , sn_tair, sn_prec, sn_snow ! " " - TYPE(FLD_N) :: sn_slp , sn_tdif, sn_cc ! " " - NAMELIST/namsbc_blk/ sn_wndi, sn_wndj, sn_humi, sn_qsr, sn_qlw , & ! input fields - & sn_tair, sn_prec, sn_snow, sn_slp, sn_tdif, sn_cc, & - & ln_NCAR, ln_COARE_3p0, ln_COARE_3p5, ln_ECMWF, & ! bulk algorithm - & cn_dir , ln_taudif, rn_zqt, rn_zu, & - & rn_pfac, rn_efac, rn_vfac, ln_Cd_L12, ln_Cd_L15 - !!--------------------------------------------------------------------- - ! - ! ! allocate sbc_blk_core array - IF( sbc_blk_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk : unable to allocate standard arrays' ) - ! - ! !** read bulk namelist - REWIND( numnam_ref ) !* Namelist namsbc_blk in reference namelist : bulk parameters - READ ( numnam_ref, namsbc_blk, IOSTAT = ios, ERR = 901) -901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_blk in reference namelist' ) - ! - REWIND( numnam_cfg ) !* Namelist namsbc_blk in configuration namelist : bulk parameters - READ ( numnam_cfg, namsbc_blk, IOSTAT = ios, ERR = 902 ) -902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_blk in configuration namelist' ) - ! - IF(lwm) WRITE( numond, namsbc_blk ) - ! - ! !** initialization of the chosen bulk formulae (+ check) - ! !* select the bulk chosen in the namelist and check the choice - ioptio = 0 - IF( ln_NCAR ) THEN ; nblk = np_NCAR ; ioptio = ioptio + 1 ; ENDIF - IF( ln_COARE_3p0 ) THEN ; nblk = np_COARE_3p0 ; ioptio = ioptio + 1 ; ENDIF - IF( ln_COARE_3p5 ) THEN ; nblk = np_COARE_3p5 ; ioptio = ioptio + 1 ; ENDIF - IF( ln_ECMWF ) THEN ; nblk = np_ECMWF ; ioptio = ioptio + 1 ; ENDIF - ! - IF( ioptio /= 1 ) CALL ctl_stop( 'sbc_blk_init: Choose one and only one bulk algorithm' ) - ! - IF( ln_dm2dc ) THEN !* check: diurnal cycle on Qsr - IF( sn_qsr%freqh /= 24. ) CALL ctl_stop( 'sbc_blk_init: ln_dm2dc=T only with daily short-wave input' ) - IF( sn_qsr%ln_tint ) THEN - CALL ctl_warn( 'sbc_blk_init: ln_dm2dc=T daily qsr time interpolation done by sbcdcy module', & - & ' ==> We force time interpolation = .false. for qsr' ) - sn_qsr%ln_tint = .false. - ENDIF - ENDIF - ! !* set the bulk structure - ! !- store namelist information in an array - slf_i(jp_wndi) = sn_wndi ; slf_i(jp_wndj) = sn_wndj - slf_i(jp_qsr ) = sn_qsr ; slf_i(jp_qlw ) = sn_qlw - slf_i(jp_tair) = sn_tair ; slf_i(jp_humi) = sn_humi - slf_i(jp_prec) = sn_prec ; slf_i(jp_snow) = sn_snow - slf_i(jp_slp) = sn_slp ; slf_i(jp_cc) = sn_cc - slf_i(jp_tdif) = sn_tdif - ! - lhftau = ln_taudif !- add an extra field if HF stress is used - jfld = jpfld - COUNT( (/.NOT.lhftau/) ) - ! - ! !- allocate the bulk structure - ALLOCATE( sf(jfld), STAT=ierror ) - IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_init: unable to allocate sf structure' ) - - ! !- fill the bulk structure with namelist informations - CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_init', 'surface boundary condition -- bulk formulae', 'namsbc_blk' ) - ! - DO jfpr = 1, jfld - ! - IF( TRIM(sf(jfpr)%clrootname) == 'NOT USED' ) THEN !-- not used field --! (only now allocated and set to zero) - ALLOCATE( sf(jfpr)%fnow(jpi,jpj,1) ) - sf(jfpr)%fnow(:,:,1) = 0._wp - ELSE !-- used field --! - ALLOCATE( sf(jfpr)%fnow(jpi,jpj,1) ) - IF( slf_i(jfpr)%ln_tint ) ALLOCATE( sf(jfpr)%fdta(jpi,jpj,1,2) ) - IF( slf_i(jfpr)%freqh > 0. .AND. MOD( NINT(3600. * slf_i(jfpr)%freqh), nn_fsbc * NINT(rdt) ) /= 0 ) & - & CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rdt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', & - & ' This is not ideal. You should consider changing either rdt or nn_fsbc value...' ) - ENDIF - ENDDO - ! fill cloud cover array with constant value if "not used" - IF( TRIM(sf(jp_cc)%clrootname) == 'NOT USED' ) sf(jp_cc)%fnow(:,:,1) = pp_cldf - - IF ( ln_wave ) THEN - !Activated wave module but neither drag nor stokes drift activated - IF ( .NOT.(ln_cdgw .OR. ln_sdw .OR. ln_tauwoc .OR. ln_stcor ) ) THEN - CALL ctl_stop( 'STOP', 'Ask for wave coupling but ln_cdgw=F, ln_sdw=F, ln_tauwoc=F, ln_stcor=F' ) - !drag coefficient read from wave model definable only with mfs bulk formulae and core - ELSEIF (ln_cdgw .AND. .NOT. ln_NCAR ) THEN - CALL ctl_stop( 'drag coefficient read from wave model definable only with NCAR and CORE bulk formulae') - ELSEIF (ln_stcor .AND. .NOT. ln_sdw) THEN - CALL ctl_stop( 'Stokes-Coriolis term calculated only if activated Stokes Drift ln_sdw=T') - ENDIF - ELSE - IF ( ln_cdgw .OR. ln_sdw .OR. ln_tauwoc .OR. ln_stcor ) & - & CALL ctl_stop( 'Not Activated Wave Module (ln_wave=F) but asked coupling ', & - & 'with drag coefficient (ln_cdgw =T) ' , & - & 'or Stokes Drift (ln_sdw=T) ' , & - & 'or ocean stress modification due to waves (ln_tauwoc=T) ', & - & 'or Stokes-Coriolis term (ln_stcori=T)' ) - ENDIF - ! - ! - IF(lwp) THEN !** Control print - ! - WRITE(numout,*) !* namelist - WRITE(numout,*) ' Namelist namsbc_blk (other than data information):' - WRITE(numout,*) ' "NCAR" algorithm (Large and Yeager 2008) ln_NCAR = ', ln_NCAR - WRITE(numout,*) ' "COARE 3.0" algorithm (Fairall et al. 2003) ln_COARE_3p0 = ', ln_COARE_3p0 - WRITE(numout,*) ' "COARE 3.5" algorithm (Edson et al. 2013) ln_COARE_3p5 = ', ln_COARE_3p5 - WRITE(numout,*) ' "ECMWF" algorithm (IFS cycle 31) ln_ECMWF = ', ln_ECMWF - WRITE(numout,*) ' add High freq.contribution to the stress module ln_taudif = ', ln_taudif - WRITE(numout,*) ' Air temperature and humidity reference height (m) rn_zqt = ', rn_zqt - WRITE(numout,*) ' Wind vector reference height (m) rn_zu = ', rn_zu - WRITE(numout,*) ' factor applied on precipitation (total & snow) rn_pfac = ', rn_pfac - WRITE(numout,*) ' factor applied on evaporation rn_efac = ', rn_efac - WRITE(numout,*) ' factor applied on ocean/ice velocity rn_vfac = ', rn_vfac - WRITE(numout,*) ' (form absolute (=0) to relative winds(=1))' - WRITE(numout,*) ' use ice-atm drag from Lupkes2012 ln_Cd_L12 = ', ln_Cd_L12 - WRITE(numout,*) ' use ice-atm drag from Lupkes2015 ln_Cd_L15 = ', ln_Cd_L15 - ! - WRITE(numout,*) - SELECT CASE( nblk ) !* Print the choice of bulk algorithm - CASE( np_NCAR ) ; WRITE(numout,*) ' ==>>> "NCAR" algorithm (Large and Yeager 2008)' - CASE( np_COARE_3p0 ) ; WRITE(numout,*) ' ==>>> "COARE 3.0" algorithm (Fairall et al. 2003)' - CASE( np_COARE_3p5 ) ; WRITE(numout,*) ' ==>>> "COARE 3.5" algorithm (Edson et al. 2013)' - CASE( np_ECMWF ) ; WRITE(numout,*) ' ==>>> "ECMWF" algorithm (IFS cycle 31)' - END SELECT - ! - ENDIF - ! - END SUBROUTINE sbc_blk_init - - - SUBROUTINE sbc_blk( kt ) - !!--------------------------------------------------------------------- - !! *** ROUTINE sbc_blk *** - !! - !! ** Purpose : provide at each time step the surface ocean fluxes - !! (momentum, heat, freshwater and runoff) - !! - !! ** Method : (1) READ each fluxes in NetCDF files: - !! the 10m wind velocity (i-component) (m/s) at T-point - !! the 10m wind velocity (j-component) (m/s) at T-point - !! the 10m or 2m specific humidity ( % ) - !! the solar heat (W/m2) - !! the Long wave (W/m2) - !! the 10m or 2m air temperature (Kelvin) - !! the total precipitation (rain+snow) (Kg/m2/s) - !! the snow (solid prcipitation) (kg/m2/s) - !! the tau diff associated to HF tau (N/m2) at T-point (ln_taudif=T) - !! (2) CALL blk_oce - !! - !! C A U T I O N : never mask the surface stress fields - !! the stress is assumed to be in the (i,j) mesh referential - !! - !! ** Action : defined at each time-step at the air-sea interface - !! - utau, vtau i- and j-component of the wind stress - !! - taum wind stress module at T-point - !! - wndm wind speed module at T-point over free ocean or leads in presence of sea-ice - !! - qns, qsr non-solar and solar heat fluxes - !! - emp upward mass flux (evapo. - precip.) - !! - sfx salt flux due to freezing/melting (non-zero only if ice is present) - !! - !! ** References : Large & Yeager, 2004 / Large & Yeager, 2008 - !! Brodeau et al. Ocean Modelling 2010 - !!---------------------------------------------------------------------- - INTEGER, INTENT(in) :: kt ! ocean time step - !!--------------------------------------------------------------------- - ! - CALL fld_read( kt, nn_fsbc, sf ) ! input fields provided at the current time-step - ! - ! ! compute the surface ocean fluxes using bulk formulea - IF( MOD( kt - 1, nn_fsbc ) == 0 ) CALL blk_oce( kt, sf, sst_m, ssu_m, ssv_m ) - -#if defined key_cice - IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN - qlw_ice(:,:,1) = sf(jp_qlw )%fnow(:,:,1) - IF( ln_dm2dc ) THEN ; qsr_ice(:,:,1) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) - ELSE ; qsr_ice(:,:,1) = sf(jp_qsr)%fnow(:,:,1) - ENDIF - tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1) - qatm_ice(:,:) = sf(jp_humi)%fnow(:,:,1) - tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac - sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac - wndi_ice(:,:) = sf(jp_wndi)%fnow(:,:,1) - wndj_ice(:,:) = sf(jp_wndj)%fnow(:,:,1) - ENDIF -#endif - ! - END SUBROUTINE sbc_blk - - - SUBROUTINE blk_oce( kt, sf, pst, pu, pv ) - !!--------------------------------------------------------------------- - !! *** ROUTINE blk_oce *** - !! - !! ** Purpose : provide the momentum, heat and freshwater fluxes at - !! the ocean surface at each time step - !! - !! ** Method : bulk formulea for the ocean using atmospheric - !! fields read in sbc_read - !! - !! ** Outputs : - utau : i-component of the stress at U-point (N/m2) - !! - vtau : j-component of the stress at V-point (N/m2) - !! - taum : Wind stress module at T-point (N/m2) - !! - wndm : Wind speed module at T-point (m/s) - !! - qsr : Solar heat flux over the ocean (W/m2) - !! - qns : Non Solar heat flux over the ocean (W/m2) - !! - emp : evaporation minus precipitation (kg/m2/s) - !! - !! ** Nota : sf has to be a dummy argument for AGRIF on NEC - !!--------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kt ! time step index - TYPE(fld), INTENT(inout), DIMENSION(:) :: sf ! input data - REAL(wp) , INTENT(in) , DIMENSION(:,:) :: pst ! surface temperature [Celcius] - REAL(wp) , INTENT(in) , DIMENSION(:,:) :: pu ! surface current at U-point (i-component) [m/s] - REAL(wp) , INTENT(in) , DIMENSION(:,:) :: pv ! surface current at V-point (j-component) [m/s] - ! - INTEGER :: ji, jj ! dummy loop indices - REAL(wp) :: zztmp ! local variable - REAL(wp), DIMENSION(jpi,jpj) :: zwnd_i, zwnd_j ! wind speed components at T-point - REAL(wp), DIMENSION(jpi,jpj) :: zsq ! specific humidity at pst - REAL(wp), DIMENSION(jpi,jpj) :: zqlw, zqsb ! long wave and sensible heat fluxes - REAL(wp), DIMENSION(jpi,jpj) :: zqla, zevap ! latent heat fluxes and evaporation - REAL(wp), DIMENSION(jpi,jpj) :: zst ! surface temperature in Kelvin - REAL(wp), DIMENSION(jpi,jpj) :: zU_zu ! bulk wind speed at height zu [m/s] - REAL(wp), DIMENSION(jpi,jpj) :: ztpot ! potential temperature of air at z=rn_zqt [K] - REAL(wp), DIMENSION(jpi,jpj) :: zrhoa ! density of air [kg/m^3] - !!--------------------------------------------------------------------- - ! - ! local scalars ( place there for vector optimisation purposes) - zst(:,:) = pst(:,:) + rt0 ! convert SST from Celcius to Kelvin (and set minimum value far above 0 K) - - ! --- cloud cover --- ! - cloud_fra(:,:) = sf(jp_cc)%fnow(:,:,1) - - ! ----------------------------------------------------------------------------- ! - ! 0 Wind components and module at T-point relative to the moving ocean ! - ! ----------------------------------------------------------------------------- ! - - ! ... components ( U10m - U_oce ) at T-point (unmasked) -!!gm move zwnd_i (_j) set to zero inside the key_cyclone ??? - zwnd_i(:,:) = 0._wp - zwnd_j(:,:) = 0._wp -#if defined key_cyclone - CALL wnd_cyc( kt, zwnd_i, zwnd_j ) ! add analytical tropical cyclone (Vincent et al. JGR 2012) - DO jj = 2, jpjm1 - DO ji = fs_2, fs_jpim1 ! vect. opt. - sf(jp_wndi)%fnow(ji,jj,1) = sf(jp_wndi)%fnow(ji,jj,1) + zwnd_i(ji,jj) - sf(jp_wndj)%fnow(ji,jj,1) = sf(jp_wndj)%fnow(ji,jj,1) + zwnd_j(ji,jj) - END DO - END DO -#endif - DO jj = 2, jpjm1 - DO ji = fs_2, fs_jpim1 ! vect. opt. - zwnd_i(ji,jj) = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pu(ji-1,jj ) + pu(ji,jj) ) ) - zwnd_j(ji,jj) = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pv(ji ,jj-1) + pv(ji,jj) ) ) - END DO - END DO - CALL lbc_lnk_multi( 'sbcblk', zwnd_i, 'T', -1., zwnd_j, 'T', -1. ) - ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked) - wndm(:,:) = SQRT( zwnd_i(:,:) * zwnd_i(:,:) & - & + zwnd_j(:,:) * zwnd_j(:,:) ) * tmask(:,:,1) - - ! ----------------------------------------------------------------------------- ! - ! I Radiative FLUXES ! - ! ----------------------------------------------------------------------------- ! - - ! ocean albedo assumed to be constant + modify now Qsr to include the diurnal cycle ! Short Wave - zztmp = 1. - albo - IF( ln_dm2dc ) THEN ; qsr(:,:) = zztmp * sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1) - ELSE ; qsr(:,:) = zztmp * sf(jp_qsr)%fnow(:,:,1) * tmask(:,:,1) - ENDIF - - zqlw(:,:) = ( sf(jp_qlw)%fnow(:,:,1) - Stef * zst(:,:)*zst(:,:)*zst(:,:)*zst(:,:) ) * tmask(:,:,1) ! Long Wave - - ! ----------------------------------------------------------------------------- ! - ! II Turbulent FLUXES ! - ! ----------------------------------------------------------------------------- ! - - ! ... specific humidity at SST and IST tmask( - zsq(:,:) = 0.98 * q_sat( zst(:,:), sf(jp_slp)%fnow(:,:,1) ) - !! - !! Estimate of potential temperature at z=rn_zqt, based on adiabatic lapse-rate - !! (see Josey, Gulev & Yu, 2013) / doi=10.1016/B978-0-12-391851-2.00005-2 - !! (since reanalysis products provide T at z, not theta !) - ztpot = sf(jp_tair)%fnow(:,:,1) + gamma_moist( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1) ) * rn_zqt - - SELECT CASE( nblk ) !== transfer coefficients ==! Cd, Ch, Ce at T-point - ! - CASE( np_NCAR ) ; CALL turb_ncar ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & ! NCAR-COREv2 - & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) - CASE( np_COARE_3p0 ) ; CALL turb_coare ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & ! COARE v3.0 - & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) - CASE( np_COARE_3p5 ) ; CALL turb_coare3p5( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & ! COARE v3.5 - & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) - CASE( np_ECMWF ) ; CALL turb_ecmwf ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & ! ECMWF - & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) - CASE DEFAULT - CALL ctl_stop( 'STOP', 'sbc_oce: non-existing bulk formula selected' ) - END SELECT - - ! ! Compute true air density : - IF( ABS(rn_zu - rn_zqt) > 0.01 ) THEN ! At zu: (probably useless to remove zrho*grav*rn_zu from SLP...) - zrhoa(:,:) = rho_air( t_zu(:,:) , q_zu(:,:) , sf(jp_slp)%fnow(:,:,1) ) - ELSE ! At zt: - zrhoa(:,:) = rho_air( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1) ) - END IF - -!! CALL iom_put( "Cd_oce", Cd_atm) ! output value of pure ocean-atm. transfer coef. -!! CALL iom_put( "Ch_oce", Ch_atm) ! output value of pure ocean-atm. transfer coef. - - DO jj = 1, jpj ! tau module, i and j component - DO ji = 1, jpi - zztmp = zrhoa(ji,jj) * zU_zu(ji,jj) * Cd_atm(ji,jj) ! using bulk wind speed - taum (ji,jj) = zztmp * wndm (ji,jj) - zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj) - zwnd_j(ji,jj) = zztmp * zwnd_j(ji,jj) - END DO - END DO - - ! ! add the HF tau contribution to the wind stress module - IF( lhftau ) taum(:,:) = taum(:,:) + sf(jp_tdif)%fnow(:,:,1) - - CALL iom_put( "taum_oce", taum ) ! output wind stress module - - ! ... utau, vtau at U- and V_points, resp. - ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines - ! Note the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves - DO jj = 1, jpjm1 - DO ji = 1, fs_jpim1 - utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj ) ) & - & * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1)) - vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( zwnd_j(ji,jj) + zwnd_j(ji ,jj+1) ) & - & * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1)) - END DO - END DO - CALL lbc_lnk_multi( 'sbcblk', utau, 'U', -1., vtau, 'V', -1. ) - - ! Turbulent fluxes over ocean - ! ----------------------------- - - ! zqla used as temporary array, for rho*U (common term of bulk formulae): - zqla(:,:) = zrhoa(:,:) * zU_zu(:,:) * tmask(:,:,1) - - IF( ABS( rn_zu - rn_zqt) < 0.01_wp ) THEN - !! q_air and t_air are given at 10m (wind reference height) - zevap(:,:) = rn_efac*MAX( 0._wp, zqla(:,:)*Ce_atm(:,:)*(zsq(:,:) - sf(jp_humi)%fnow(:,:,1)) ) ! Evaporation, using bulk wind speed - zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch_atm(:,:)*(zst(:,:) - ztpot(:,:) ) ! Sensible Heat, using bulk wind speed - ELSE - !! q_air and t_air are not given at 10m (wind reference height) - ! Values of temp. and hum. adjusted to height of wind during bulk algorithm iteration must be used!!! - zevap(:,:) = rn_efac*MAX( 0._wp, zqla(:,:)*Ce_atm(:,:)*(zsq(:,:) - q_zu(:,:) ) ) ! Evaporation, using bulk wind speed - zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch_atm(:,:)*(zst(:,:) - t_zu(:,:) ) ! Sensible Heat, using bulk wind speed - ENDIF - - zqla(:,:) = L_vap(zst(:,:)) * zevap(:,:) ! Latent Heat flux - - - IF(ln_ctl) THEN - CALL prt_ctl( tab2d_1=zqla , clinfo1=' blk_oce: zqla : ', tab2d_2=Ce_atm , clinfo2=' Ce_oce : ' ) - CALL prt_ctl( tab2d_1=zqsb , clinfo1=' blk_oce: zqsb : ', tab2d_2=Ch_atm , clinfo2=' Ch_oce : ' ) - CALL prt_ctl( tab2d_1=zqlw , clinfo1=' blk_oce: zqlw : ', tab2d_2=qsr, clinfo2=' qsr : ' ) - CALL prt_ctl( tab2d_1=zsq , clinfo1=' blk_oce: zsq : ', tab2d_2=zst, clinfo2=' zst : ' ) - CALL prt_ctl( tab2d_1=utau , clinfo1=' blk_oce: utau : ', mask1=umask, & - & tab2d_2=vtau , clinfo2= ' vtau : ', mask2=vmask ) - CALL prt_ctl( tab2d_1=wndm , clinfo1=' blk_oce: wndm : ') - CALL prt_ctl( tab2d_1=zst , clinfo1=' blk_oce: zst : ') - ENDIF - - ! ----------------------------------------------------------------------------- ! - ! III Total FLUXES ! - ! ----------------------------------------------------------------------------- ! - ! - emp (:,:) = ( zevap(:,:) & ! mass flux (evap. - precip.) - & - sf(jp_prec)%fnow(:,:,1) * rn_pfac ) * tmask(:,:,1) - ! - qns(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:) & ! Downward Non Solar - & - sf(jp_snow)%fnow(:,:,1) * rn_pfac * rLfus & ! remove latent melting heat for solid precip - & - zevap(:,:) * pst(:,:) * rcp & ! remove evap heat content at SST - & + ( sf(jp_prec)%fnow(:,:,1) - sf(jp_snow)%fnow(:,:,1) ) * rn_pfac & ! add liquid precip heat content at Tair - & * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp & - & + sf(jp_snow)%fnow(:,:,1) * rn_pfac & ! add solid precip heat content at min(Tair,Tsnow) - & * ( MIN( sf(jp_tair)%fnow(:,:,1), rt0 ) - rt0 ) * rcpi - qns(:,:) = qns(:,:) * tmask(:,:,1) - ! -#if defined key_si3 - qns_oce(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:) ! non solar without emp (only needed by SI3) - qsr_oce(:,:) = qsr(:,:) -#endif - ! -! DRM, 11/07/18 - move the beginning of the IF loop to get the diagnostics I want. -! IF ( nn_ice == 0 ) THEN - CALL iom_put( "qlw_oce" , zqlw ) ! output downward longwave heat over the ocean - CALL iom_put( "qsb_oce" , - zqsb ) ! output downward sensible heat over the ocean - CALL iom_put( "qla_oce" , - zqla ) ! output downward latent heat over the ocean - CALL iom_put( "qemp_oce", qns-zqlw+zqsb+zqla ) ! output downward heat content of E-P over the ocean - CALL iom_put( "qns_oce" , qns ) ! output downward non solar heat over the ocean - CALL iom_put( "qsr_oce" , qsr ) ! output downward solar heat over the ocean - CALL iom_put( "qt_oce" , qns+qsr ) ! output total downward heat over the ocean - IF ( nn_ice == 0 ) THEN - tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac * tmask(:,:,1) ! output total precipitation [kg/m2/s] - sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac * tmask(:,:,1) ! output solid precipitation [kg/m2/s] - CALL iom_put( 'snowpre', sprecip ) ! Snow - CALL iom_put( 'precip' , tprecip ) ! Total precipitation - ENDIF - ! - IF(ln_ctl) THEN - CALL prt_ctl(tab2d_1=zqsb , clinfo1=' blk_oce: zqsb : ', tab2d_2=zqlw , clinfo2=' zqlw : ') - CALL prt_ctl(tab2d_1=zqla , clinfo1=' blk_oce: zqla : ', tab2d_2=qsr , clinfo2=' qsr : ') - CALL prt_ctl(tab2d_1=pst , clinfo1=' blk_oce: pst : ', tab2d_2=emp , clinfo2=' emp : ') - CALL prt_ctl(tab2d_1=utau , clinfo1=' blk_oce: utau : ', mask1=umask, & - & tab2d_2=vtau , clinfo2= ' vtau : ' , mask2=vmask ) - ENDIF - ! - END SUBROUTINE blk_oce - - - - FUNCTION rho_air( ptak, pqa, pslp ) - !!------------------------------------------------------------------------------- - !! *** FUNCTION rho_air *** - !! - !! ** Purpose : compute density of (moist) air using the eq. of state of the atmosphere - !! - !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) - !!------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pslp ! pressure in [Pa] - REAL(wp), DIMENSION(jpi,jpj) :: rho_air ! density of moist air [kg/m^3] - !!------------------------------------------------------------------------------- - ! - rho_air = pslp / ( R_dry*ptak * ( 1._wp + rctv0*pqa ) ) - ! - END FUNCTION rho_air - - - FUNCTION cp_air( pqa ) - !!------------------------------------------------------------------------------- - !! *** FUNCTION cp_air *** - !! - !! ** Purpose : Compute specific heat (Cp) of moist air - !! - !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) - !!------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] - REAL(wp), DIMENSION(jpi,jpj) :: cp_air ! specific heat of moist air [J/K/kg] - !!------------------------------------------------------------------------------- - ! - Cp_air = Cp_dry + Cp_vap * pqa - ! - END FUNCTION cp_air - - - FUNCTION q_sat( ptak, pslp ) - !!---------------------------------------------------------------------------------- - !! *** FUNCTION q_sat *** - !! - !! ** Purpose : Specific humidity at saturation in [kg/kg] - !! Based on accurate estimate of "e_sat" - !! aka saturation water vapor (Goff, 1957) - !! - !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) - !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pslp ! sea level atmospheric pressure [Pa] - REAL(wp), DIMENSION(jpi,jpj) :: q_sat ! Specific humidity at saturation [kg/kg] - ! - INTEGER :: ji, jj ! dummy loop indices - REAL(wp) :: ze_sat, ztmp ! local scalar - !!---------------------------------------------------------------------------------- - ! - DO jj = 1, jpj - DO ji = 1, jpi - ! - ztmp = rt0 / ptak(ji,jj) - ! - ! Vapour pressure at saturation [hPa] : WMO, (Goff, 1957) - ze_sat = 10.**( 10.79574*(1. - ztmp) - 5.028*LOG10(ptak(ji,jj)/rt0) & - & + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(ptak(ji,jj)/rt0 - 1.)) ) & - & + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614 ) - ! - q_sat(ji,jj) = reps0 * ze_sat/( 0.01_wp*pslp(ji,jj) - (1._wp - reps0)*ze_sat ) ! 0.01 because SLP is in [Pa] - ! - END DO - END DO - ! - END FUNCTION q_sat - - - FUNCTION gamma_moist( ptak, pqa ) - !!---------------------------------------------------------------------------------- - !! *** FUNCTION gamma_moist *** - !! - !! ** Purpose : Compute the moist adiabatic lapse-rate. - !! => http://glossary.ametsoc.org/wiki/Moist-adiabatic_lapse_rate - !! => http://www.geog.ucsb.edu/~joel/g266_s10/lecture_notes/chapt03/oh10_3_01/oh10_3_01.html - !! - !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) - !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity [kg/kg] - REAL(wp), DIMENSION(jpi,jpj) :: gamma_moist ! moist adiabatic lapse-rate - ! - INTEGER :: ji, jj ! dummy loop indices - REAL(wp) :: zrv, ziRT ! local scalar - !!---------------------------------------------------------------------------------- - ! - DO jj = 1, jpj - DO ji = 1, jpi - zrv = pqa(ji,jj) / (1. - pqa(ji,jj)) - ziRT = 1. / (R_dry*ptak(ji,jj)) ! 1/RT - gamma_moist(ji,jj) = grav * ( 1. + rLevap*zrv*ziRT ) / ( Cp_dry + rLevap*rLevap*zrv*reps0*ziRT/ptak(ji,jj) ) - END DO - END DO - ! - END FUNCTION gamma_moist - - - FUNCTION L_vap( psst ) - !!--------------------------------------------------------------------------------- - !! *** FUNCTION L_vap *** - !! - !! ** Purpose : Compute the latent heat of vaporization of water from temperature - !! - !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) - !!---------------------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: L_vap ! latent heat of vaporization [J/kg] - REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! water temperature [K] - !!---------------------------------------------------------------------------------- - ! - L_vap = ( 2.501 - 0.00237 * ( psst(:,:) - rt0) ) * 1.e6 - ! - END FUNCTION L_vap - -#if defined key_si3 - !!---------------------------------------------------------------------- - !! 'key_si3' SI3 sea-ice model - !!---------------------------------------------------------------------- - !! blk_ice_tau : provide the air-ice stress - !! blk_ice_flx : provide the heat and mass fluxes at air-ice interface - !! blk_ice_qcn : provide ice surface temperature and snow/ice conduction flux (emulating conduction flux) - !! Cdn10_Lupkes2012 : Lupkes et al. (2012) air-ice drag - !! Cdn10_Lupkes2015 : Lupkes et al. (2015) air-ice drag - !!---------------------------------------------------------------------- - - SUBROUTINE blk_ice_tau - !!--------------------------------------------------------------------- - !! *** ROUTINE blk_ice_tau *** - !! - !! ** Purpose : provide the surface boundary condition over sea-ice - !! - !! ** Method : compute momentum using bulk formulation - !! formulea, ice variables and read atmospheric fields. - !! NB: ice drag coefficient is assumed to be a constant - !!--------------------------------------------------------------------- - INTEGER :: ji, jj ! dummy loop indices - REAL(wp) :: zwndi_f , zwndj_f, zwnorm_f ! relative wind module and components at F-point - REAL(wp) :: zwndi_t , zwndj_t ! relative wind components at T-point - REAL(wp) :: zztmp1 , zztmp2 ! temporary values - REAL(wp), DIMENSION(jpi,jpj) :: zrhoa ! transfer coefficient for momentum (tau) - !!--------------------------------------------------------------------- - ! - ! set transfer coefficients to default sea-ice values - Cd_atm(:,:) = Cd_ice - Ch_atm(:,:) = Cd_ice - Ce_atm(:,:) = Cd_ice - - wndm_ice(:,:) = 0._wp !!gm brutal.... - - ! ------------------------------------------------------------ ! - ! Wind module relative to the moving ice ( U10m - U_ice ) ! - ! ------------------------------------------------------------ ! - ! C-grid ice dynamics : U & V-points (same as ocean) - DO jj = 2, jpjm1 - DO ji = fs_2, fs_jpim1 ! vect. opt. - zwndi_t = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) ) - zwndj_t = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) ) - wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) - END DO - END DO - CALL lbc_lnk( 'sbcblk', wndm_ice, 'T', 1. ) - ! - ! Make ice-atm. drag dependent on ice concentration - IF ( ln_Cd_L12 ) THEN ! calculate new drag from Lupkes(2012) equations - CALL Cdn10_Lupkes2012( Cd_atm ) - Ch_atm(:,:) = Cd_atm(:,:) ! momentum and heat transfer coef. are considered identical - ELSEIF( ln_Cd_L15 ) THEN ! calculate new drag from Lupkes(2015) equations - CALL Cdn10_Lupkes2015( Cd_atm, Ch_atm ) - ENDIF - -!! CALL iom_put( "Cd_ice", Cd_atm) ! output value of pure ice-atm. transfer coef. -!! CALL iom_put( "Ch_ice", Ch_atm) ! output value of pure ice-atm. transfer coef. - - ! local scalars ( place there for vector optimisation purposes) - ! Computing density of air! Way denser that 1.2 over sea-ice !!! - zrhoa (:,:) = rho_air(sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1)) - - ! ------------------------------------------------------------ ! - ! Wind stress relative to the moving ice ( U10m - U_ice ) ! - ! ------------------------------------------------------------ ! - zztmp1 = rn_vfac * 0.5_wp - DO jj = 2, jpj ! at T point - DO ji = 2, jpi - zztmp2 = zrhoa(ji,jj) * Cd_atm(ji,jj) * wndm_ice(ji,jj) - utau_ice(ji,jj) = zztmp2 * ( sf(jp_wndi)%fnow(ji,jj,1) - zztmp1 * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) ) - vtau_ice(ji,jj) = zztmp2 * ( sf(jp_wndj)%fnow(ji,jj,1) - zztmp1 * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) ) - END DO - END DO - ! - DO jj = 2, jpjm1 ! U & V-points (same as ocean). - DO ji = fs_2, fs_jpim1 ! vect. opt. - ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology - zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) - zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) ) - utau_ice(ji,jj) = zztmp1 * ( utau_ice(ji,jj) + utau_ice(ji+1,jj ) ) - vtau_ice(ji,jj) = zztmp2 * ( vtau_ice(ji,jj) + vtau_ice(ji ,jj+1) ) - END DO - END DO - CALL lbc_lnk_multi( 'sbcblk', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) - ! - ! - IF(ln_ctl) THEN - CALL prt_ctl(tab2d_1=utau_ice , clinfo1=' blk_ice: utau_ice : ', tab2d_2=vtau_ice , clinfo2=' vtau_ice : ') - CALL prt_ctl(tab2d_1=wndm_ice , clinfo1=' blk_ice: wndm_ice : ') - ENDIF - ! - END SUBROUTINE blk_ice_tau - - - SUBROUTINE blk_ice_flx( ptsu, phs, phi, palb ) - !!--------------------------------------------------------------------- - !! *** ROUTINE blk_ice_flx *** - !! - !! ** Purpose : provide the heat and mass fluxes at air-ice interface - !! - !! ** Method : compute heat and freshwater exchanged - !! between atmosphere and sea-ice using bulk formulation - !! formulea, ice variables and read atmmospheric fields. - !! - !! caution : the net upward water flux has with mm/day unit - !!--------------------------------------------------------------------- - REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptsu ! sea ice surface temperature - REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness - REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness - REAL(wp), DIMENSION(:,:,:), INTENT(in) :: palb ! ice albedo (all skies) - !! - INTEGER :: ji, jj, jl ! dummy loop indices - REAL(wp) :: zst3 ! local variable - REAL(wp) :: zcoef_dqlw, zcoef_dqla ! - - - REAL(wp) :: zztmp, z1_rLsub ! - - - REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_st ! inverse of surface temperature - REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qlw ! long wave heat flux over ice - REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qsb ! sensible heat flux over ice - REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_dqlw ! long wave heat sensitivity over ice - REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_dqsb ! sensible heat sensitivity over ice - REAL(wp), DIMENSION(jpi,jpj) :: zevap, zsnw ! evaporation and snw distribution after wind blowing (SI3) - REAL(wp), DIMENSION(jpi,jpj) :: zrhoa - REAL(wp), DIMENSION(jpi,jpj) :: ztmp, ztmp2 - REAL(wp), DIMENSION(jpi,jpj) :: ztri - !!--------------------------------------------------------------------- - ! - zcoef_dqlw = 4.0 * 0.95 * Stef ! local scalars - zcoef_dqla = -Ls * 11637800. * (-5897.8) - ! - zrhoa(:,:) = rho_air( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1) ) - ! - zztmp = 1. / ( 1. - albo ) - WHERE( ptsu(:,:,:) /= 0._wp ) ; z1_st(:,:,:) = 1._wp / ptsu(:,:,:) - ELSEWHERE ; z1_st(:,:,:) = 0._wp - END WHERE - ! ! ========================== ! - DO jl = 1, jpl ! Loop over ice categories ! - ! ! ========================== ! - DO jj = 1 , jpj - DO ji = 1, jpi - ! ----------------------------! - ! I Radiative FLUXES ! - ! ----------------------------! - zst3 = ptsu(ji,jj,jl) * ptsu(ji,jj,jl) * ptsu(ji,jj,jl) - ! Short Wave (sw) - qsr_ice(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj) - ! Long Wave (lw) - z_qlw(ji,jj,jl) = 0.95 * ( sf(jp_qlw)%fnow(ji,jj,1) - Stef * ptsu(ji,jj,jl) * zst3 ) * tmask(ji,jj,1) - ! lw sensitivity - z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3 - - ! ----------------------------! - ! II Turbulent FLUXES ! - ! ----------------------------! - - ! ... turbulent heat fluxes with Ch_atm recalculated in blk_ice_tau - ! Sensible Heat - z_qsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * Ch_atm(ji,jj) * wndm_ice(ji,jj) * (ptsu(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1)) - ! Latent Heat - qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, zrhoa(ji,jj) * Ls * Ch_atm(ji,jj) * wndm_ice(ji,jj) * & - & ( 11637800. * EXP( -5897.8 * z1_st(ji,jj,jl) ) / zrhoa(ji,jj) - sf(jp_humi)%fnow(ji,jj,1) ) ) - ! Latent heat sensitivity for ice (Dqla/Dt) - IF( qla_ice(ji,jj,jl) > 0._wp ) THEN - dqla_ice(ji,jj,jl) = rn_efac * zcoef_dqla * Ch_atm(ji,jj) * wndm_ice(ji,jj) * & - & z1_st(ji,jj,jl)*z1_st(ji,jj,jl) * EXP(-5897.8 * z1_st(ji,jj,jl)) - ELSE - dqla_ice(ji,jj,jl) = 0._wp - ENDIF - - ! Sensible heat sensitivity (Dqsb_ice/Dtn_ice) - z_dqsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * Ch_atm(ji,jj) * wndm_ice(ji,jj) - - ! ----------------------------! - ! III Total FLUXES ! - ! ----------------------------! - ! Downward Non Solar flux - qns_ice (ji,jj,jl) = z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - qla_ice (ji,jj,jl) - ! Total non solar heat flux sensitivity for ice - dqns_ice(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + dqla_ice(ji,jj,jl) ) - END DO - ! - END DO - ! - END DO - ! - tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac * tmask(:,:,1) ! total precipitation [kg/m2/s] - sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac * tmask(:,:,1) ! solid precipitation [kg/m2/s] - CALL iom_put( 'snowpre', sprecip ) ! Snow precipitation - CALL iom_put( 'precip' , tprecip ) ! Total precipitation - - ! --- evaporation --- ! - z1_rLsub = 1._wp / rLsub - evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_rLsub ! sublimation - devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_rLsub ! d(sublimation)/dT - zevap (:,:) = rn_efac * ( emp(:,:) + tprecip(:,:) ) ! evaporation over ocean - - ! --- evaporation minus precipitation --- ! - zsnw(:,:) = 0._wp - CALL ice_var_snwblow( (1.-at_i_b(:,:)), zsnw ) ! snow distribution over ice after wind blowing - emp_oce(:,:) = ( 1._wp - at_i_b(:,:) ) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) - emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw - emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:) - - ! --- heat flux associated with emp --- ! - qemp_oce(:,:) = - ( 1._wp - at_i_b(:,:) ) * zevap(:,:) * sst_m(:,:) * rcp & ! evap at sst - & + ( tprecip(:,:) - sprecip(:,:) ) * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp & ! liquid precip at Tair - & + sprecip(:,:) * ( 1._wp - zsnw ) * & ! solid precip at min(Tair,Tsnow) - & ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0 ) - rt0 ) * rcpi * tmask(:,:,1) - rLfus ) - qemp_ice(:,:) = sprecip(:,:) * zsnw * & ! solid precip (only) - & ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0 ) - rt0 ) * rcpi * tmask(:,:,1) - rLfus ) - - ! --- total solar and non solar fluxes --- ! - qns_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) & - & + qemp_ice(:,:) + qemp_oce(:,:) - qsr_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) - - ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! - qprec_ice(:,:) = rhos * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0 ) - rt0 ) * rcpi * tmask(:,:,1) - rLfus ) - - ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- - DO jl = 1, jpl - qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * rcpi * tmask(:,:,1) ) - ! ! But we do not have Tice => consider it at 0degC => evap=0 - END DO - - ! --- shortwave radiation transmitted thru the surface scattering layer (W/m2) --- ! - IF( nn_qtrice == 0 ) THEN - ! formulation derived from Grenfell and Maykut (1977), where transmission rate - ! 1) depends on cloudiness - ! 2) is 0 when there is any snow - ! 3) tends to 1 for thin ice - ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm - DO jl = 1, jpl - WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm - qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) - ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm - qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:) - ELSEWHERE ! zero when hs>0 - qtr_ice_top(:,:,jl) = 0._wp - END WHERE - ENDDO - ELSEIF( nn_qtrice == 1 ) THEN - ! formulation is derived from the thesis of M. Lebrun (2019). - ! It represents the best fit using several sets of observations - ! It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90) - qtr_ice_top(:,:,:) = 0.3_wp * qsr_ice(:,:,:) - ENDIF - ! - - IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) THEN - ztmp(:,:) = zevap(:,:) * ( 1._wp - at_i_b(:,:) ) - CALL iom_put( 'evap_ao_cea' , ztmp(:,:) * tmask(:,:,1) ) ! ice-free oce evap (cell average) - CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * sst_m(:,:) * rcp * tmask(:,:,1) ) ! heat flux from evap (cell average) - ENDIF - IF( iom_use('hflx_rain_cea') ) THEN - ztmp(:,:) = rcp * ( SUM( (ptsu-rt0) * a_i_b, dim=3 ) + sst_m(:,:) * ( 1._wp - at_i_b(:,:) ) ) - CALL iom_put( 'hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * ztmp(:,:) ) ! heat flux from rain (cell average) - ENDIF - IF( iom_use('hflx_snow_cea') .OR. iom_use('hflx_snow_ao_cea') .OR. iom_use('hflx_snow_ai_cea') ) THEN - WHERE( SUM( a_i_b, dim=3 ) > 1.e-10 ) ; ztmp(:,:) = rcpi * SUM( (ptsu-rt0) * a_i_b, dim=3 ) / SUM( a_i_b, dim=3 ) - ELSEWHERE ; ztmp(:,:) = rcp * sst_m(:,:) - ENDWHERE - ztmp2(:,:) = sprecip(:,:) * ( ztmp(:,:) - rLfus ) - CALL iom_put('hflx_snow_cea' , ztmp2(:,:) ) ! heat flux from snow (cell average) - CALL iom_put('hflx_snow_ao_cea', ztmp2(:,:) * ( 1._wp - zsnw(:,:) ) ) ! heat flux from snow (over ocean) - CALL iom_put('hflx_snow_ai_cea', ztmp2(:,:) * zsnw(:,:) ) ! heat flux from snow (over ice) - ENDIF - ! - IF(ln_ctl) THEN - CALL prt_ctl(tab3d_1=qla_ice , clinfo1=' blk_ice: qla_ice : ', tab3d_2=z_qsb , clinfo2=' z_qsb : ', kdim=jpl) - CALL prt_ctl(tab3d_1=z_qlw , clinfo1=' blk_ice: z_qlw : ', tab3d_2=dqla_ice, clinfo2=' dqla_ice : ', kdim=jpl) - CALL prt_ctl(tab3d_1=z_dqsb , clinfo1=' blk_ice: z_dqsb : ', tab3d_2=z_dqlw , clinfo2=' z_dqlw : ', kdim=jpl) - CALL prt_ctl(tab3d_1=dqns_ice, clinfo1=' blk_ice: dqns_ice : ', tab3d_2=qsr_ice , clinfo2=' qsr_ice : ', kdim=jpl) - CALL prt_ctl(tab3d_1=ptsu , clinfo1=' blk_ice: ptsu : ', tab3d_2=qns_ice , clinfo2=' qns_ice : ', kdim=jpl) - CALL prt_ctl(tab2d_1=tprecip , clinfo1=' blk_ice: tprecip : ', tab2d_2=sprecip , clinfo2=' sprecip : ') - ENDIF - ! - END SUBROUTINE blk_ice_flx - - - SUBROUTINE blk_ice_qcn( ld_virtual_itd, ptsu, ptb, phs, phi ) - !!--------------------------------------------------------------------- - !! *** ROUTINE blk_ice_qcn *** - !! - !! ** Purpose : Compute surface temperature and snow/ice conduction flux - !! to force sea ice / snow thermodynamics - !! in the case conduction flux is emulated - !! - !! ** Method : compute surface energy balance assuming neglecting heat storage - !! following the 0-layer Semtner (1976) approach - !! - !! ** Outputs : - ptsu : sea-ice / snow surface temperature (K) - !! - qcn_ice : surface inner conduction flux (W/m2) - !! - !!--------------------------------------------------------------------- - LOGICAL , INTENT(in ) :: ld_virtual_itd ! single-category option - REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptsu ! sea ice / snow surface temperature - REAL(wp), DIMENSION(:,:) , INTENT(in ) :: ptb ! sea ice base temperature - REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phs ! snow thickness - REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phi ! sea ice thickness - ! - INTEGER , PARAMETER :: nit = 10 ! number of iterations - REAL(wp), PARAMETER :: zepsilon = 0.1_wp ! characteristic thickness for enhanced conduction - ! - INTEGER :: ji, jj, jl ! dummy loop indices - INTEGER :: iter ! local integer - REAL(wp) :: zfac, zfac2, zfac3 ! local scalars - REAL(wp) :: zkeff_h, ztsu, ztsu0 ! - REAL(wp) :: zqc, zqnet ! - REAL(wp) :: zhe, zqa0 ! - REAL(wp), DIMENSION(jpi,jpj,jpl) :: zgfac ! enhanced conduction factor - !!--------------------------------------------------------------------- - - ! -------------------------------------! - ! I Enhanced conduction factor ! - ! -------------------------------------! - ! Emulates the enhancement of conduction by unresolved thin ice (ld_virtual_itd = T) - ! Fichefet and Morales Maqueda, JGR 1997 - ! - zgfac(:,:,:) = 1._wp - - IF( ld_virtual_itd ) THEN - ! - zfac = 1._wp / ( rn_cnd_s + rcnd_i ) - zfac2 = EXP(1._wp) * 0.5_wp * zepsilon - zfac3 = 2._wp / zepsilon - ! - DO jl = 1, jpl - DO jj = 1 , jpj - DO ji = 1, jpi - zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcnd_i * phs(ji,jj,jl) ) * zfac ! Effective thickness - IF( zhe >= zfac2 ) zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor - END DO - END DO - END DO - ! - ENDIF - - ! -------------------------------------------------------------! - ! II Surface temperature and conduction flux ! - ! -------------------------------------------------------------! - ! - zfac = rcnd_i * rn_cnd_s - ! - DO jl = 1, jpl - DO jj = 1 , jpj - DO ji = 1, jpi - ! - zkeff_h = zfac * zgfac(ji,jj,jl) / & ! Effective conductivity of the snow-ice system divided by thickness - & ( rcnd_i * phs(ji,jj,jl) + rn_cnd_s * MAX( 0.01, phi(ji,jj,jl) ) ) - ztsu = ptsu(ji,jj,jl) ! Store current iteration temperature - ztsu0 = ptsu(ji,jj,jl) ! Store initial surface temperature - zqa0 = qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) ! Net initial atmospheric heat flux - ! - DO iter = 1, nit ! --- Iterative loop - zqc = zkeff_h * ( ztsu - ptb(ji,jj) ) ! Conduction heat flux through snow-ice system (>0 downwards) - zqnet = zqa0 + dqns_ice(ji,jj,jl) * ( ztsu - ptsu(ji,jj,jl) ) - zqc ! Surface energy budget - ztsu = ztsu - zqnet / ( dqns_ice(ji,jj,jl) - zkeff_h ) ! Temperature update - END DO - ! - ptsu (ji,jj,jl) = MIN( rt0, ztsu ) - qcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) ) - qns_ice(ji,jj,jl) = qns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) - qml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) - qcn_ice(ji,jj,jl) ) & - & * MAX( 0._wp , SIGN( 1._wp, ptsu(ji,jj,jl) - rt0 ) ) - - ! --- Diagnose the heat loss due to changing non-solar flux (as in icethd_zdf_bl99) --- ! - hfx_err_dif(ji,jj) = hfx_err_dif(ji,jj) - ( dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) ) * a_i_b(ji,jj,jl) - - END DO - END DO - ! - END DO - ! - END SUBROUTINE blk_ice_qcn - - - SUBROUTINE Cdn10_Lupkes2012( Cd ) - !!---------------------------------------------------------------------- - !! *** ROUTINE Cdn10_Lupkes2012 *** - !! - !! ** Purpose : Recompute the neutral air-ice drag referenced at 10m - !! to make it dependent on edges at leads, melt ponds and flows. - !! After some approximations, this can be resumed to a dependency - !! on ice concentration. - !! - !! ** Method : The parameterization is taken from Lupkes et al. (2012) eq.(50) - !! with the highest level of approximation: level4, eq.(59) - !! The generic drag over a cell partly covered by ice can be re-written as follows: - !! - !! Cd = Cdw * (1-A) + Cdi * A + Ce * (1-A)**(nu+1/(10*beta)) * A**mu - !! - !! Ce = 2.23e-3 , as suggested by Lupkes (eq. 59) - !! nu = mu = beta = 1 , as suggested by Lupkes (eq. 59) - !! A is the concentration of ice minus melt ponds (if any) - !! - !! This new drag has a parabolic shape (as a function of A) starting at - !! Cdw(say 1.5e-3) for A=0, reaching 1.97e-3 for A~0.5 - !! and going down to Cdi(say 1.4e-3) for A=1 - !! - !! It is theoretically applicable to all ice conditions (not only MIZ) - !! => see Lupkes et al (2013) - !! - !! ** References : Lupkes et al. JGR 2012 (theory) - !! Lupkes et al. GRL 2013 (application to GCM) - !! - !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(:,:), INTENT(inout) :: Cd - REAL(wp), PARAMETER :: zCe = 2.23e-03_wp - REAL(wp), PARAMETER :: znu = 1._wp - REAL(wp), PARAMETER :: zmu = 1._wp - REAL(wp), PARAMETER :: zbeta = 1._wp - REAL(wp) :: zcoef - !!---------------------------------------------------------------------- - zcoef = znu + 1._wp / ( 10._wp * zbeta ) - - ! generic drag over a cell partly covered by ice - !!Cd(:,:) = Cd_oce(:,:) * ( 1._wp - at_i_b(:,:) ) + & ! pure ocean drag - !! & Cd_ice * at_i_b(:,:) + & ! pure ice drag - !! & zCe * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**zmu ! change due to sea-ice morphology - - ! ice-atm drag - Cd(:,:) = Cd_ice + & ! pure ice drag - & zCe * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**(zmu-1._wp) ! change due to sea-ice morphology - - END SUBROUTINE Cdn10_Lupkes2012 - - - SUBROUTINE Cdn10_Lupkes2015( Cd, Ch ) - !!---------------------------------------------------------------------- - !! *** ROUTINE Cdn10_Lupkes2015 *** - !! - !! ** pUrpose : Alternative turbulent transfert coefficients formulation - !! between sea-ice and atmosphere with distinct momentum - !! and heat coefficients depending on sea-ice concentration - !! and atmospheric stability (no meltponds effect for now). - !! - !! ** Method : The parameterization is adapted from Lupkes et al. (2015) - !! and ECHAM6 atmospheric model. Compared to Lupkes2012 scheme, - !! it considers specific skin and form drags (Andreas et al. 2010) - !! to compute neutral transfert coefficients for both heat and - !! momemtum fluxes. Atmospheric stability effect on transfert - !! coefficient is also taken into account following Louis (1979). - !! - !! ** References : Lupkes et al. JGR 2015 (theory) - !! Lupkes et al. ECHAM6 documentation 2015 (implementation) - !! - !!---------------------------------------------------------------------- - ! - REAL(wp), DIMENSION(:,:), INTENT(inout) :: Cd - REAL(wp), DIMENSION(:,:), INTENT(inout) :: Ch - REAL(wp), DIMENSION(jpi,jpj) :: ztm_su, zst, zqo_sat, zqi_sat - ! - ! ECHAM6 constants - REAL(wp), PARAMETER :: z0_skin_ice = 0.69e-3_wp ! Eq. 43 [m] - REAL(wp), PARAMETER :: z0_form_ice = 0.57e-3_wp ! Eq. 42 [m] - REAL(wp), PARAMETER :: z0_ice = 1.00e-3_wp ! Eq. 15 [m] - REAL(wp), PARAMETER :: zce10 = 2.80e-3_wp ! Eq. 41 - REAL(wp), PARAMETER :: zbeta = 1.1_wp ! Eq. 41 - REAL(wp), PARAMETER :: zc = 5._wp ! Eq. 13 - REAL(wp), PARAMETER :: zc2 = zc * zc - REAL(wp), PARAMETER :: zam = 2. * zc ! Eq. 14 - REAL(wp), PARAMETER :: zah = 3. * zc ! Eq. 30 - REAL(wp), PARAMETER :: z1_alpha = 1._wp / 0.2_wp ! Eq. 51 - REAL(wp), PARAMETER :: z1_alphaf = z1_alpha ! Eq. 56 - REAL(wp), PARAMETER :: zbetah = 1.e-3_wp ! Eq. 26 - REAL(wp), PARAMETER :: zgamma = 1.25_wp ! Eq. 26 - REAL(wp), PARAMETER :: z1_gamma = 1._wp / zgamma - REAL(wp), PARAMETER :: r1_3 = 1._wp / 3._wp - ! - INTEGER :: ji, jj ! dummy loop indices - REAL(wp) :: zthetav_os, zthetav_is, zthetav_zu - REAL(wp) :: zrib_o, zrib_i - REAL(wp) :: zCdn_skin_ice, zCdn_form_ice, zCdn_ice - REAL(wp) :: zChn_skin_ice, zChn_form_ice - REAL(wp) :: z0w, z0i, zfmi, zfmw, zfhi, zfhw - REAL(wp) :: zCdn_form_tmp - !!---------------------------------------------------------------------- - - ! mean temperature - WHERE( at_i_b(:,:) > 1.e-20 ) ; ztm_su(:,:) = SUM( t_su(:,:,:) * a_i_b(:,:,:) , dim=3 ) / at_i_b(:,:) - ELSEWHERE ; ztm_su(:,:) = rt0 - ENDWHERE - - ! Momentum Neutral Transfert Coefficients (should be a constant) - zCdn_form_tmp = zce10 * ( LOG( 10._wp / z0_form_ice + 1._wp ) / LOG( rn_zu / z0_form_ice + 1._wp ) )**2 ! Eq. 40 - zCdn_skin_ice = ( vkarmn / LOG( rn_zu / z0_skin_ice + 1._wp ) )**2 ! Eq. 7 - zCdn_ice = zCdn_skin_ice ! Eq. 7 (cf Lupkes email for details) - !zCdn_ice = 1.89e-3 ! old ECHAM5 value (cf Eq. 32) - - ! Heat Neutral Transfert Coefficients - zChn_skin_ice = vkarmn**2 / ( LOG( rn_zu / z0_ice + 1._wp ) * LOG( rn_zu * z1_alpha / z0_skin_ice + 1._wp ) ) ! Eq. 50 + Eq. 52 (cf Lupkes email for details) - - ! Atmospheric and Surface Variables - zst(:,:) = sst_m(:,:) + rt0 ! convert SST from Celcius to Kelvin - zqo_sat(:,:) = 0.98_wp * q_sat( zst(:,:) , sf(jp_slp)%fnow(:,:,1) ) ! saturation humidity over ocean [kg/kg] - zqi_sat(:,:) = 0.98_wp * q_sat( ztm_su(:,:), sf(jp_slp)%fnow(:,:,1) ) ! saturation humidity over ice [kg/kg] - ! - DO jj = 2, jpjm1 ! reduced loop is necessary for reproducibility - DO ji = fs_2, fs_jpim1 - ! Virtual potential temperature [K] - zthetav_os = zst(ji,jj) * ( 1._wp + rctv0 * zqo_sat(ji,jj) ) ! over ocean - zthetav_is = ztm_su(ji,jj) * ( 1._wp + rctv0 * zqi_sat(ji,jj) ) ! ocean ice - zthetav_zu = t_zu (ji,jj) * ( 1._wp + rctv0 * q_zu(ji,jj) ) ! at zu - - ! Bulk Richardson Number (could use Ri_bulk function from aerobulk instead) - zrib_o = grav / zthetav_os * ( zthetav_zu - zthetav_os ) * rn_zu / MAX( 0.5, wndm(ji,jj) )**2 ! over ocean - zrib_i = grav / zthetav_is * ( zthetav_zu - zthetav_is ) * rn_zu / MAX( 0.5, wndm_ice(ji,jj) )**2 ! over ice - - ! Momentum and Heat Neutral Transfert Coefficients - zCdn_form_ice = zCdn_form_tmp * at_i_b(ji,jj) * ( 1._wp - at_i_b(ji,jj) )**zbeta ! Eq. 40 - zChn_form_ice = zCdn_form_ice / ( 1._wp + ( LOG( z1_alphaf ) / vkarmn ) * SQRT( zCdn_form_ice ) ) ! Eq. 53 - - ! Momentum and Heat Stability functions (possibility to use psi_m_ecmwf instead) - z0w = rn_zu * EXP( -1._wp * vkarmn / SQRT( Cdn_oce(ji,jj) ) ) ! over water - z0i = z0_skin_ice ! over ice (cf Lupkes email for details) - IF( zrib_o <= 0._wp ) THEN - zfmw = 1._wp - zam * zrib_o / ( 1._wp + 3._wp * zc2 * Cdn_oce(ji,jj) * SQRT( -zrib_o * ( rn_zu / z0w + 1._wp ) ) ) ! Eq. 10 - zfhw = ( 1._wp + ( zbetah * ( zthetav_os - zthetav_zu )**r1_3 / ( Chn_oce(ji,jj) * MAX(0.01, wndm(ji,jj)) ) & ! Eq. 26 - & )**zgamma )**z1_gamma - ELSE - zfmw = 1._wp / ( 1._wp + zam * zrib_o / SQRT( 1._wp + zrib_o ) ) ! Eq. 12 - zfhw = 1._wp / ( 1._wp + zah * zrib_o / SQRT( 1._wp + zrib_o ) ) ! Eq. 28 - ENDIF - - IF( zrib_i <= 0._wp ) THEN - zfmi = 1._wp - zam * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp))) ! Eq. 9 - zfhi = 1._wp - zah * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp))) ! Eq. 25 - ELSE - zfmi = 1._wp / ( 1._wp + zam * zrib_i / SQRT( 1._wp + zrib_i ) ) ! Eq. 11 - zfhi = 1._wp / ( 1._wp + zah * zrib_i / SQRT( 1._wp + zrib_i ) ) ! Eq. 27 - ENDIF - - ! Momentum Transfert Coefficients (Eq. 38) - Cd(ji,jj) = zCdn_skin_ice * zfmi + & - & zCdn_form_ice * ( zfmi * at_i_b(ji,jj) + zfmw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) - - ! Heat Transfert Coefficients (Eq. 49) - Ch(ji,jj) = zChn_skin_ice * zfhi + & - & zChn_form_ice * ( zfhi * at_i_b(ji,jj) + zfhw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) - ! - END DO - END DO - CALL lbc_lnk_multi( 'sbcblk', Cd, 'T', 1., Ch, 'T', 1. ) - ! - END SUBROUTINE Cdn10_Lupkes2015 - -#endif - - !!====================================================================== -END MODULE sbcblk diff --git a/MY_SRC/sbcrnf.F90 b/MY_SRC/sbcrnf.F90 deleted file mode 100644 index b8362c5..0000000 --- a/MY_SRC/sbcrnf.F90 +++ /dev/null @@ -1,552 +0,0 @@ -MODULE sbcrnf - !!====================================================================== - !! *** MODULE sbcrnf *** - !! Ocean forcing: river runoff - !!===================================================================== - !! History : OPA ! 2000-11 (R. Hordoir, E. Durand) NetCDF FORMAT - !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module - !! 3.0 ! 2006-07 (G. Madec) Surface module - !! 3.2 ! 2009-04 (B. Lemaire) Introduce iom_put - !! 3.3 ! 2010-10 (R. Furner, G. Madec) runoff distributed over ocean levels - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! sbc_rnf : monthly runoffs read in a NetCDF file - !! sbc_rnf_init : runoffs initialisation - !! rnf_mouth : set river mouth mask - !!---------------------------------------------------------------------- - USE dom_oce ! ocean space and time domain - USE phycst ! physical constants - USE sbc_oce ! surface boundary condition variables - USE eosbn2 ! Equation Of State - USE closea, ONLY: l_clo_rnf, clo_rnf ! closed seas - ! - USE in_out_manager ! I/O manager - USE fldread ! read input field at current time step - USE iom ! I/O module - USE lib_mpp ! MPP library - - IMPLICIT NONE - PRIVATE - - PUBLIC sbc_rnf ! called in sbcmod module - PUBLIC sbc_rnf_div ! called in divhor module - PUBLIC sbc_rnf_alloc ! called in sbcmod module - PUBLIC sbc_rnf_init ! called in sbcmod module - - ! !!* namsbc_rnf namelist * - CHARACTER(len=100) :: cn_dir !: Root directory for location of rnf files - LOGICAL , PUBLIC :: ln_rnf_depth !: depth river runoffs attribute specified in a file - LOGICAL :: ln_rnf_depth_ini !: depth river runoffs computed at the initialisation - REAL(wp) :: rn_rnf_max !: maximum value of the runoff climatologie (ln_rnf_depth_ini =T) - REAL(wp) :: rn_dep_max !: depth over which runoffs is spread (ln_rnf_depth_ini =T) - INTEGER :: nn_rnf_depth_file !: create (=1) a runoff depth file or not (=0) - LOGICAL :: ln_rnf_icb !: iceberg flux is specified in a file - LOGICAL :: ln_rnf_tem !: temperature river runoffs attribute specified in a file - LOGICAL , PUBLIC :: ln_rnf_sal !: salinity river runoffs attribute specified in a file - TYPE(FLD_N) , PUBLIC :: sn_rnf !: information about the runoff file to be read - TYPE(FLD_N) :: sn_cnf !: information about the runoff mouth file to be read - TYPE(FLD_N) :: sn_i_rnf !: information about the iceberg flux file to be read - TYPE(FLD_N) :: sn_s_rnf !: information about the salinities of runoff file to be read - TYPE(FLD_N) :: sn_t_rnf !: information about the temperatures of runoff file to be read - TYPE(FLD_N) :: sn_dep_rnf !: information about the depth which river inflow affects - LOGICAL , PUBLIC :: ln_rnf_mouth !: specific treatment in mouths vicinity - REAL(wp) :: rn_hrnf !: runoffs, depth over which enhanced vertical mixing is used - REAL(wp) , PUBLIC :: rn_avt_rnf !: runoffs, value of the additional vertical mixing coef. [m2/s] - REAL(wp) , PUBLIC :: rn_rfact !: multiplicative factor for runoff - - LOGICAL , PUBLIC :: l_rnfcpl = .false. !: runoffs recieved from oasis - INTEGER , PUBLIC :: nkrnf = 0 !: nb of levels over which Kz is increased at river mouths - - REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnfmsk !: river mouth mask (hori.) - REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rnfmsk_z !: river mouth mask (vert.) - REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_rnf !: depth of runoff in m - INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nk_rnf !: depth of runoff in model levels - REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rnf_tsc_b, rnf_tsc !: before and now T & S runoff contents [K.m/s & PSU.m/s] - - TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_rnf ! structure: river runoff (file information, fields read) - TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_i_rnf ! structure: iceberg flux (file information, fields read) - TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_s_rnf ! structure: river runoff salinity (file information, fields read) - TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_t_rnf ! structure: river runoff temperature (file information, fields read) - - !!---------------------------------------------------------------------- - !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: sbcrnf.F90 12277 2019-12-20 11:54:47Z cetlod $ - !! Software governed by the CeCILL license (see ./LICENSE) - !!---------------------------------------------------------------------- -CONTAINS - - INTEGER FUNCTION sbc_rnf_alloc() - !!---------------------------------------------------------------------- - !! *** ROUTINE sbc_rnf_alloc *** - !!---------------------------------------------------------------------- - ALLOCATE( rnfmsk(jpi,jpj) , rnfmsk_z(jpk) , & - & h_rnf (jpi,jpj) , nk_rnf (jpi,jpj) , & - & rnf_tsc_b(jpi,jpj,jpts) , rnf_tsc (jpi,jpj,jpts) , STAT=sbc_rnf_alloc ) - ! - CALL mpp_sum ( 'sbcrnf', sbc_rnf_alloc ) - IF( sbc_rnf_alloc > 0 ) CALL ctl_warn('sbc_rnf_alloc: allocation of arrays failed') - END FUNCTION sbc_rnf_alloc - - - SUBROUTINE sbc_rnf( kt ) - !!---------------------------------------------------------------------- - !! *** ROUTINE sbc_rnf *** - !! - !! ** Purpose : Introduce a climatological run off forcing - !! - !! ** Method : Set each river mouth with a monthly climatology - !! provided from different data. - !! CAUTION : upward water flux, runoff forced to be < 0 - !! - !! ** Action : runoff updated runoff field at time-step kt - !!---------------------------------------------------------------------- - INTEGER, INTENT(in) :: kt ! ocean time step - ! - INTEGER :: ji, jj ! dummy loop indices - INTEGER :: z_err = 0 ! dummy integer for error handling - !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point used for temperature correction - ! - ! - ! !-------------------! - ! ! Update runoff ! - ! !-------------------! - ! - ! - IF( .NOT. l_rnfcpl ) THEN - CALL fld_read ( kt, nn_fsbc, sf_rnf ) ! Read Runoffs data and provide it at kt ( runoffs + iceberg ) - IF( ln_rnf_icb ) CALL fld_read ( kt, nn_fsbc, sf_i_rnf ) ! idem for iceberg flux if required - ENDIF - IF( ln_rnf_tem ) CALL fld_read ( kt, nn_fsbc, sf_t_rnf ) ! idem for runoffs temperature if required - IF( ln_rnf_sal ) CALL fld_read ( kt, nn_fsbc, sf_s_rnf ) ! idem for runoffs salinity if required - ! - IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN - ! - IF( .NOT. l_rnfcpl ) THEN - rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt - IF( ln_rnf_icb ) THEN - fwficb(:,:) = rn_rfact * ( sf_i_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt - CALL iom_put( 'iceberg_cea' , fwficb(:,:) ) ! output iceberg flux - CALL iom_put( 'hflx_icb_cea' , fwficb(:,:) * rLfus ) ! output Heat Flux into Sea Water due to Iceberg Thermodynamics --> - ENDIF - ENDIF - ! - ! ! set temperature & salinity content of runoffs - IF( ln_rnf_tem ) THEN ! use runoffs temperature data - rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 - CALL eos_fzp( sss_m(:,:), ztfrz(:,:) ) - WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp ) ! if missing data value use SST as runoffs temperature - rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 - END WHERE - ELSE ! use SST as runoffs temperature - !CEOD River is fresh water so must at least be 0 unless we consider ice - rnf_tsc(:,:,jp_tem) = MAX( sst_m(:,:), 0.0_wp ) * rnf(:,:) * r1_rau0 - ENDIF - ! ! use runoffs salinity data - IF( ln_rnf_sal ) rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 - ! ! else use S=0 for runoffs (done one for all in the init) - CALL iom_put( 'runoffs' , rnf(:,:) ) ! output runoff mass flux - IF( iom_use('hflx_rnf_cea') ) CALL iom_put( 'hflx_rnf_cea', rnf_tsc(:,:,jp_tem) * rau0 * rcp ) ! output runoff sensible heat (W/m2) - ENDIF - ! - ! ! ---------------------------------------- ! - IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! - ! ! ---------------------------------------- ! - IF( ln_rstart .AND. & !* Restart: read in restart file - & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN - IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields red in the restart file', lrxios - CALL iom_get( numror, jpdom_autoglo, 'rnf_b', rnf_b, ldxios = lrxios ) ! before runoff - CALL iom_get( numror, jpdom_autoglo, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content of runoff - CALL iom_get( numror, jpdom_autoglo, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salinity content of runoff - ELSE !* no restart: set from nit000 values - IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields set to nit000' - rnf_b (:,: ) = rnf (:,: ) - rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) - ENDIF - ENDIF - ! ! ---------------------------------------- ! - IF( lrst_oce ) THEN ! Write in the ocean restart file ! - ! ! ---------------------------------------- ! - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'sbcrnf : runoff forcing fields written in ocean restart file ', & - & 'at it= ', kt,' date= ', ndastp - IF(lwp) WRITE(numout,*) '~~~~' - IF( lwxios ) CALL iom_swap( cwxios_context ) - CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf, ldxios = lwxios ) - CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem), ldxios = lwxios ) - CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal), ldxios = lwxios ) - IF( lwxios ) CALL iom_swap( cxios_context ) - ENDIF - ! - END SUBROUTINE sbc_rnf - - - SUBROUTINE sbc_rnf_div( phdivn ) - !!---------------------------------------------------------------------- - !! *** ROUTINE sbc_rnf *** - !! - !! ** Purpose : update the horizontal divergence with the runoff inflow - !! - !! ** Method : - !! CAUTION : rnf is positive (inflow) decreasing the - !! divergence and expressed in m/s - !! - !! ** Action : phdivn decreased by the runoff inflow - !!---------------------------------------------------------------------- - REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence - !! - INTEGER :: ji, jj, jk ! dummy loop indices - REAL(wp) :: zfact ! local scalar - !!---------------------------------------------------------------------- - ! - zfact = 0.5_wp - ! - IF( ln_rnf_depth .OR. ln_rnf_depth_ini ) THEN !== runoff distributed over several levels ==! - IF( ln_linssh ) THEN !* constant volume case : just apply the runoff input flow - DO jj = 1, jpj - DO ji = 1, jpi - DO jk = 1, nk_rnf(ji,jj) - phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rau0 / h_rnf(ji,jj) - END DO - END DO - END DO - ELSE !* variable volume case - DO jj = 1, jpj ! update the depth over which runoffs are distributed - DO ji = 1, jpi - h_rnf(ji,jj) = 0._wp - DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres - h_rnf(ji,jj) = h_rnf(ji,jj) + e3t_n(ji,jj,jk) ! to the bottom of the relevant grid box - END DO - ! ! apply the runoff input flow - DO jk = 1, nk_rnf(ji,jj) - phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rau0 / h_rnf(ji,jj) - END DO - END DO - END DO - ENDIF - ELSE !== runoff put only at the surface ==! - h_rnf (:,:) = e3t_n (:,:,1) ! update h_rnf to be depth of top box - phdivn(:,:,1) = phdivn(:,:,1) - ( rnf(:,:) + rnf_b(:,:) ) * zfact * r1_rau0 / e3t_n(:,:,1) - ENDIF - ! - END SUBROUTINE sbc_rnf_div - - - SUBROUTINE sbc_rnf_init - !!---------------------------------------------------------------------- - !! *** ROUTINE sbc_rnf_init *** - !! - !! ** Purpose : Initialisation of the runoffs if (ln_rnf=T) - !! - !! ** Method : - read the runoff namsbc_rnf namelist - !! - !! ** Action : - read parameters - !!---------------------------------------------------------------------- - CHARACTER(len=32) :: rn_dep_file ! runoff file name - INTEGER :: ji, jj, jk, jm ! dummy loop indices - INTEGER :: ierror, inum ! temporary integer - INTEGER :: ios ! Local integer output status for namelist read - INTEGER :: nbrec ! temporary integer - REAL(wp) :: zacoef - REAL(wp), DIMENSION(jpi,jpj,2) :: zrnfcl - !! - NAMELIST/namsbc_rnf/ cn_dir , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal, ln_rnf_icb, & - & sn_rnf, sn_cnf , sn_i_rnf, sn_s_rnf , sn_t_rnf , sn_dep_rnf, & - & ln_rnf_mouth , rn_hrnf , rn_avt_rnf, rn_rfact, & - & ln_rnf_depth_ini , rn_dep_max , rn_rnf_max, nn_rnf_depth_file - !!---------------------------------------------------------------------- - ! - ! !== allocate runoff arrays - IF( sbc_rnf_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' ) - ! - IF( .NOT. ln_rnf ) THEN ! no specific treatment in vicinity of river mouths - ln_rnf_mouth = .FALSE. ! default definition needed for example by sbc_ssr or by tra_adv_muscl - nkrnf = 0 - rnf (:,:) = 0.0_wp - rnf_b (:,:) = 0.0_wp - rnfmsk (:,:) = 0.0_wp - rnfmsk_z(:) = 0.0_wp - RETURN - ENDIF - ! - ! ! ============ - ! ! Namelist - ! ! ============ - ! - REWIND( numnam_ref ) - READ ( numnam_ref, namsbc_rnf, IOSTAT = ios, ERR = 901) -901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist' ) - - REWIND( numnam_cfg ) - READ ( numnam_cfg, namsbc_rnf, IOSTAT = ios, ERR = 902 ) -902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist' ) - IF(lwm) WRITE ( numond, namsbc_rnf ) - ! - ! ! Control print - IF(lwp) THEN - WRITE(numout,*) - WRITE(numout,*) 'sbc_rnf_init : runoff ' - WRITE(numout,*) '~~~~~~~~~~~~ ' - WRITE(numout,*) ' Namelist namsbc_rnf' - WRITE(numout,*) ' specific river mouths treatment ln_rnf_mouth = ', ln_rnf_mouth - WRITE(numout,*) ' river mouth additional Kz rn_avt_rnf = ', rn_avt_rnf - WRITE(numout,*) ' depth of river mouth additional mixing rn_hrnf = ', rn_hrnf - WRITE(numout,*) ' multiplicative factor for runoff rn_rfact = ', rn_rfact - ENDIF - ! ! ================== - ! ! Type of runoff - ! ! ================== - ! - IF( .NOT. l_rnfcpl ) THEN - ALLOCATE( sf_rnf(1), STAT=ierror ) ! Create sf_rnf structure (runoff inflow) - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' ==>>> runoffs inflow read in a file' - IF( ierror > 0 ) THEN - CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_rnf structure' ) ; RETURN - ENDIF - ALLOCATE( sf_rnf(1)%fnow(jpi,jpj,1) ) - IF( sn_rnf%ln_tint ) ALLOCATE( sf_rnf(1)%fdta(jpi,jpj,1,2) ) - CALL fld_fill( sf_rnf, (/ sn_rnf /), cn_dir, 'sbc_rnf_init', 'read runoffs data', 'namsbc_rnf', no_print ) - ! - IF( ln_rnf_icb ) THEN ! Create (if required) sf_i_rnf structure - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' iceberg flux read in a file' - ALLOCATE( sf_i_rnf(1), STAT=ierror ) - IF( ierror > 0 ) THEN - CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_i_rnf structure' ) ; RETURN - ENDIF - ALLOCATE( sf_i_rnf(1)%fnow(jpi,jpj,1) ) - IF( sn_i_rnf%ln_tint ) ALLOCATE( sf_i_rnf(1)%fdta(jpi,jpj,1,2) ) - CALL fld_fill (sf_i_rnf, (/ sn_i_rnf /), cn_dir, 'sbc_rnf_init', 'read iceberg flux data', 'namsbc_rnf' ) - ELSE - fwficb(:,:) = 0._wp - ENDIF - - ENDIF - ! - IF( ln_rnf_tem ) THEN ! Create (if required) sf_t_rnf structure - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' ==>>> runoffs temperatures read in a file' - ALLOCATE( sf_t_rnf(1), STAT=ierror ) - IF( ierror > 0 ) THEN - CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_t_rnf structure' ) ; RETURN - ENDIF - ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1) ) - IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) ) - CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf', no_print ) - ENDIF - ! - IF( ln_rnf_sal ) THEN ! Create (if required) sf_s_rnf and sf_t_rnf structures - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' ==>>> runoffs salinities read in a file' - ALLOCATE( sf_s_rnf(1), STAT=ierror ) - IF( ierror > 0 ) THEN - CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_s_rnf structure' ) ; RETURN - ENDIF - ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1) ) - IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) ) - CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf', no_print ) - ENDIF - ! - IF( ln_rnf_depth ) THEN ! depth of runoffs set from a file - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' ==>>> runoffs depth read in a file' - rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) - IF( .NOT. sn_dep_rnf%ln_clim ) THEN ; WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear ! add year - IF( sn_dep_rnf%cltype == 'monthly' ) WRITE(rn_dep_file, '(a,"m",i2)' ) TRIM( rn_dep_file ), nmonth ! add month - ENDIF - CALL iom_open ( rn_dep_file, inum ) ! open file - CALL iom_get ( inum, jpdom_data, sn_dep_rnf%clvar, h_rnf ) ! read the river mouth array - CALL iom_close( inum ) ! close file - ! - nk_rnf(:,:) = 0 ! set the number of level over which river runoffs are applied - DO jj = 1, jpj - DO ji = 1, jpi - IF( h_rnf(ji,jj) > 0._wp ) THEN - jk = 2 - DO WHILE ( jk < mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 - END DO - nk_rnf(ji,jj) = jk - ELSEIF( h_rnf(ji,jj) == -1._wp ) THEN ; nk_rnf(ji,jj) = 1 - ELSEIF( h_rnf(ji,jj) == -999._wp ) THEN ; nk_rnf(ji,jj) = mbkt(ji,jj) - ELSE - CALL ctl_stop( 'sbc_rnf_init: runoff depth not positive, and not -999 or -1, rnf value in file fort.999' ) - WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj) - ENDIF - END DO - END DO - DO jj = 1, jpj ! set the associated depth - DO ji = 1, jpi - h_rnf(ji,jj) = 0._wp - DO jk = 1, nk_rnf(ji,jj) - h_rnf(ji,jj) = h_rnf(ji,jj) + e3t_n(ji,jj,jk) - END DO - END DO - END DO - ! - ELSE IF( ln_rnf_depth_ini ) THEN ! runoffs applied at the surface - ! - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' ==>>> depth of runoff computed once from max value of runoff' - IF(lwp) WRITE(numout,*) ' max value of the runoff climatologie (over global domain) rn_rnf_max = ', rn_rnf_max - IF(lwp) WRITE(numout,*) ' depth over which runoffs is spread rn_dep_max = ', rn_dep_max - IF(lwp) WRITE(numout,*) ' create (=1) a runoff depth file or not (=0) nn_rnf_depth_file = ', nn_rnf_depth_file - - CALL iom_open( TRIM( cn_dir )//TRIM( sn_rnf%clname ), inum ) ! open runoff file - nbrec = iom_getszuld( inum ) - zrnfcl(:,:,1) = 0._wp ! init the max to 0. in 1 - DO jm = 1, nbrec - CALL iom_get( inum, jpdom_data, TRIM( sn_rnf%clvar ), zrnfcl(:,:,2), jm ) ! read the value in 2 - zrnfcl(:,:,1) = MAXVAL( zrnfcl(:,:,:), DIM=3 ) ! store the maximum value in time in 1 - END DO - CALL iom_close( inum ) - ! - h_rnf(:,:) = 1. - ! - zacoef = rn_dep_max / rn_rnf_max ! coef of linear relation between runoff and its depth (150m for max of runoff) - ! - WHERE( zrnfcl(:,:,1) > 0._wp ) h_rnf(:,:) = zacoef * zrnfcl(:,:,1) ! compute depth for all runoffs - ! - DO jj = 1, jpj ! take in account min depth of ocean rn_hmin - DO ji = 1, jpi - IF( zrnfcl(ji,jj,1) > 0._wp ) THEN - jk = mbkt(ji,jj) - h_rnf(ji,jj) = MIN( h_rnf(ji,jj), gdept_0(ji,jj,jk ) ) - ENDIF - END DO - END DO - ! - nk_rnf(:,:) = 0 ! number of levels on which runoffs are distributed - DO jj = 1, jpj - DO ji = 1, jpi - IF( zrnfcl(ji,jj,1) > 0._wp ) THEN - jk = 2 - DO WHILE ( jk < mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 - END DO - nk_rnf(ji,jj) = jk - ELSE - nk_rnf(ji,jj) = 1 - ENDIF - END DO - END DO - ! - DO jj = 1, jpj ! set the associated depth - DO ji = 1, jpi - h_rnf(ji,jj) = 0._wp - DO jk = 1, nk_rnf(ji,jj) - h_rnf(ji,jj) = h_rnf(ji,jj) + e3t_n(ji,jj,jk) - END DO - END DO - END DO - ! - IF( nn_rnf_depth_file == 1 ) THEN ! save output nb levels for runoff - IF(lwp) WRITE(numout,*) ' ==>>> create runoff depht file', TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) - CALL iom_open ( TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ), inum, ldwrt = .TRUE. ) - CALL iom_rstput( 0, 0, inum, 'rodepth', h_rnf ) - CALL iom_close ( inum ) - ENDIF - ELSE ! runoffs applied at the surface - nk_rnf(:,:) = 1 - h_rnf (:,:) = e3t_n(:,:,1) - ENDIF - ! - rnf(:,:) = 0._wp ! runoff initialisation - rnf_tsc(:,:,:) = 0._wp ! runoffs temperature & salinty contents initilisation - ! - ! ! ======================== - ! ! River mouth vicinity - ! ! ======================== - ! - IF( ln_rnf_mouth ) THEN ! Specific treatment in vicinity of river mouths : - ! ! - Increase Kz in surface layers ( rn_hrnf > 0 ) - ! ! - set to zero SSS damping (ln_ssr=T) - ! ! - mixed upstream-centered (ln_traadv_cen2=T) - ! - IF( ln_rnf_depth ) CALL ctl_warn( 'sbc_rnf_init: increased mixing turned on but effects may already', & - & 'be spread through depth by ln_rnf_depth' ) - ! - nkrnf = 0 ! Number of level over which Kz increase - IF( rn_hrnf > 0._wp ) THEN - nkrnf = 2 - DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf ) ; nkrnf = nkrnf + 1 - END DO - IF( ln_sco ) CALL ctl_warn( 'sbc_rnf_init: number of levels over which Kz is increased is computed for zco...' ) - ENDIF - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' ==>>> Specific treatment used in vicinity of river mouths :' - IF(lwp) WRITE(numout,*) ' - Increase Kz in surface layers (if rn_hrnf > 0 )' - IF(lwp) WRITE(numout,*) ' by ', rn_avt_rnf,' m2/s over ', nkrnf, ' w-levels' - IF(lwp) WRITE(numout,*) ' - set to zero SSS damping (if ln_ssr=T)' - IF(lwp) WRITE(numout,*) ' - mixed upstream-centered (if ln_traadv_cen2=T)' - ! - CALL rnf_mouth ! set river mouth mask - ! - ELSE ! No treatment at river mouths - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' ==>>> No specific treatment at river mouths' - rnfmsk (:,:) = 0._wp - rnfmsk_z(:) = 0._wp - nkrnf = 0 - ENDIF - ! - IF( lwxios ) THEN - CALL iom_set_rstw_var_active('rnf_b') - CALL iom_set_rstw_var_active('rnf_hc_b') - CALL iom_set_rstw_var_active('rnf_sc_b') - ENDIF - - END SUBROUTINE sbc_rnf_init - - - SUBROUTINE rnf_mouth - !!---------------------------------------------------------------------- - !! *** ROUTINE rnf_mouth *** - !! - !! ** Purpose : define the river mouths mask - !! - !! ** Method : read the river mouth mask (=0/1) in the river runoff - !! climatological file. Defined a given vertical structure. - !! CAUTION, the vertical structure is hard coded on the - !! first 5 levels. - !! This fields can be used to: - !! - set an upstream advection scheme - !! (ln_rnf_mouth=T and ln_traadv_cen2=T) - !! - increase vertical on the top nn_krnf vertical levels - !! at river runoff input grid point (nn_krnf>=2, see step.F90) - !! - set to zero SSS restoring flux at river mouth grid points - !! - !! ** Action : rnfmsk set to 1 at river runoff input, 0 elsewhere - !! rnfmsk_z vertical structure - !!---------------------------------------------------------------------- - INTEGER :: inum ! temporary integers - CHARACTER(len=140) :: cl_rnfile ! runoff file name - !!---------------------------------------------------------------------- - ! - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' rnf_mouth : river mouth mask' - IF(lwp) WRITE(numout,*) ' ~~~~~~~~~ ' - ! - cl_rnfile = TRIM( cn_dir )//TRIM( sn_cnf%clname ) - IF( .NOT. sn_cnf%ln_clim ) THEN ; WRITE(cl_rnfile, '(a,"_y",i4)' ) TRIM( cl_rnfile ), nyear ! add year - IF( sn_cnf%cltype == 'monthly' ) WRITE(cl_rnfile, '(a,"m",i2)' ) TRIM( cl_rnfile ), nmonth ! add month - ENDIF - ! - ! horizontal mask (read in NetCDF file) - CALL iom_open ( cl_rnfile, inum ) ! open file - CALL iom_get ( inum, jpdom_data, sn_cnf%clvar, rnfmsk ) ! read the river mouth array - CALL iom_close( inum ) ! close file - ! - IF( l_clo_rnf ) CALL clo_rnf( rnfmsk ) ! closed sea inflow set as river mouth - ! - rnfmsk_z(:) = 0._wp ! vertical structure - rnfmsk_z(1) = 1.0 - rnfmsk_z(2) = 1.0 ! ********** - rnfmsk_z(3) = 0.5 ! HARD CODED on the 5 first levels - rnfmsk_z(4) = 0.25 ! ********** - rnfmsk_z(5) = 0.125 - ! - END SUBROUTINE rnf_mouth - - !!====================================================================== -END MODULE sbcrnf diff --git a/MY_SRC/traadv_mus.F90 b/MY_SRC/traadv_mus.F90 index 9baec79..6587299 100755 --- a/MY_SRC/traadv_mus.F90 +++ b/MY_SRC/traadv_mus.F90 @@ -28,33 +28,34 @@ MODULE traadv_mus USE iom ! XIOS library USE in_out_manager ! I/O manager USE lib_mpp ! distribued memory computing - USE lbclnk ! ocean lateral boundary condition (or mpp link) - USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) IMPLICIT NONE PRIVATE PUBLIC tra_adv_mus ! routine called by traadv.F90 - + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits ! ! and in closed seas (orca 2 and 1 configurations) REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xind !: mixed upstream/centered index - + LOGICAL :: l_trd ! flag to compute trends LOGICAL :: l_ptr ! flag to compute poleward transport LOGICAL :: l_hst ! flag to compute heat/salt transport !! * Substitutions -# include "vectopt_loop_substitute.h90" +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" !!---------------------------------------------------------------------- !! NEMO/OCE 4.0 , NEMO Consortium (2018) - !! $Id: traadv_mus.F90 11993 2019-11-28 10:20:53Z cetlod $ + !! $Id: traadv_mus.F90 15512 2021-11-15 17:22:03Z techene $ !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS - SUBROUTINE tra_adv_mus( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & - & ptb, pta, kjpt, ld_msc_ups ) + SUBROUTINE tra_adv_mus( kt, kit000, cdtype, p2dt, pU, pV, pW, & + & Kbb, Kmm, pt, kjpt, Krhs, ld_msc_ups ) !!---------------------------------------------------------------------- !! *** ROUTINE tra_adv_mus *** !! @@ -63,65 +64,68 @@ SUBROUTINE tra_adv_mus( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & !! Conservation Laws) and add it to the general tracer trend. !! !! ** Method : MUSCL scheme plus centered scheme at ocean boundaries - !! ld_msc_ups=T : + !! ld_msc_ups=T : !! - !! ** Action : - update pta with the now advective tracer trends + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) - !! - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) !! !! References : Estubier, A., and M. Levy, Notes Techn. Pole de Modelisation !! IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) !!---------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kt ! ocean time-step index - INTEGER , INTENT(in ) :: kit000 ! first time step index - CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) - INTEGER , INTENT(in ) :: kjpt ! number of tracers - LOGICAL , INTENT(in ) :: ld_msc_ups ! use upstream scheme within muscl - REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step - REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components - REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before tracer field - REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + LOGICAL , INTENT(in ) :: ld_msc_ups ! use upstream scheme within muscl + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation ! INTEGER :: ji, jj, jk, jn ! dummy loop indices INTEGER :: ierr ! local integer REAL(wp) :: zu, z0u, zzwx, zw , zalpha ! local scalars REAL(wp) :: zv, z0v, zzwy, z0w ! - - - REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwx, zslpx ! 3D workspace - REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwy, zslpy ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zslpx ! 3D workspace + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zslpy ! - - !!---------------------------------------------------------------------- ! - IF( kt == kit000 ) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'tra_adv : MUSCL advection scheme on ', cdtype - IF(lwp) WRITE(numout,*) ' : mixed up-stream ', ld_msc_ups - IF(lwp) WRITE(numout,*) '~~~~~~~' - IF(lwp) WRITE(numout,*) - ! - ! Upstream / MUSCL scheme indicator - ! - ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr ) - xind(:,:,:) = 1._wp ! set equal to 1 where up-stream is not needed - ! - IF( ld_msc_ups ) THEN ! define the upstream indicator (if asked) - ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) - upsmsk(:,:) = 0._wp ! not upstream by default + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv : MUSCL advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) ' : mixed up-stream ', ld_msc_ups + IF(lwp) WRITE(numout,*) '~~~~~~~' + IF(lwp) WRITE(numout,*) + ! + ! Upstream / MUSCL scheme indicator + ! + ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr ) + xind(:,:,:) = 1._wp ! set equal to 1 where up-stream is not needed ! - DO jk = 1, jpkm1 - xind(:,:,jk) = 1._wp & ! =>1 where up-stream is not needed - & - MAX ( rnfmsk(:,:) * rnfmsk_z(jk), & ! =>0 near runoff mouths (& closed sea outflows) - & upsmsk(:,:) ) * tmask(:,:,jk) ! =>0 in some user defined area - END DO - ENDIF + IF( ld_msc_ups ) THEN ! define the upstream indicator (if asked) + ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) + upsmsk(:,:) = 0._wp ! not upstream by default + ! + DO jk = 1, jpkm1 + xind(:,:,jk) = 1._wp & ! =>1 where up-stream is not needed + & - MAX ( rnfmsk(:,:) * rnfmsk_z(jk), & ! =>0 near runoff mouths (& closed sea outflows) + & upsmsk(:,:) ) * tmask(:,:,jk) ! =>0 in some user defined area + END DO + ENDIF + ! + ENDIF ! - ENDIF - ! - l_trd = .FALSE. - l_hst = .FALSE. - l_ptr = .FALSE. - IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. - IF( cdtype == 'TRA' .AND. ln_diaptr ) l_ptr = .TRUE. - IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & - & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + l_trd = .FALSE. + l_hst = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( l_diaptr .AND. cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( l_iom .AND. cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF ! DO jn = 1, kjpt !== loop over the tracers ==! ! @@ -129,91 +133,64 @@ SUBROUTINE tra_adv_mus( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & ! ! !-- first guess of the slopes zwx(:,:,jpk) = 0._wp ! bottom values - zwy(:,:,jpk) = 0._wp - DO jk = 1, jpkm1 ! interior values - DO jj = 1, jpjm1 - DO ji = 1, fs_jpim1 ! vector opt. - zwx(ji,jj,jk) = umask(ji,jj,jk) * ( ptb(ji+1,jj,jk,jn) - ptb(ji,jj,jk,jn) ) - zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( ptb(ji,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) - END DO - END DO - END DO - ! lateral boundary conditions (changed sign) - CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. ) + zwy(:,:,jpk) = 0._wp + DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) + zwx(ji,jj,jk) = umask(ji,jj,jk) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + END_3D ! !-- Slopes of tracer zslpx(:,:,jpk) = 0._wp ! bottom values zslpy(:,:,jpk) = 0._wp - DO jk = 1, jpkm1 ! interior values - DO jj = 2, jpj - DO ji = fs_2, jpi ! vector opt. - zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) & - & * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj ,jk) ) ) - zslpy(ji,jj,jk) = ( zwy(ji,jj,jk) + zwy(ji ,jj-1,jk) ) & - & * ( 0.25 + SIGN( 0.25, zwy(ji,jj,jk) * zwy(ji ,jj-1,jk) ) ) - END DO - END DO - END DO - ! - DO jk = 1, jpkm1 !-- Slopes limitation - DO jj = 2, jpj - DO ji = fs_2, jpi ! vector opt. - zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), & - & 2.*ABS( zwx (ji-1,jj,jk) ), & - & 2.*ABS( zwx (ji ,jj,jk) ) ) - zslpy(ji,jj,jk) = SIGN( 1., zslpy(ji,jj,jk) ) * MIN( ABS( zslpy(ji,jj ,jk) ), & - & 2.*ABS( zwy (ji,jj-1,jk) ), & - & 2.*ABS( zwy (ji,jj ,jk) ) ) - END DO - END DO - END DO - ! - DO jk = 1, jpkm1 !-- MUSCL horizontal advective fluxes - DO jj = 2, jpjm1 - DO ji = fs_2, fs_jpim1 ! vector opt. - ! MUSCL fluxes - z0u = SIGN( 0.5, pun(ji,jj,jk) ) - zalpha = 0.5 - z0u - zu = z0u - 0.5 * pun(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) - zzwx = ptb(ji+1,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk) - zzwy = ptb(ji ,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji ,jj,jk) - zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) - ! - z0v = SIGN( 0.5, pvn(ji,jj,jk) ) - zalpha = 0.5 - z0v - zv = z0v - 0.5 * pvn(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) - zzwx = ptb(ji,jj+1,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk) - zzwy = ptb(ji,jj ,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj ,jk) - zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) - END DO - END DO - END DO - CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. ) ! lateral boundary conditions (changed sign) - ! - DO jk = 1, jpkm1 !-- Tracer advective trend - DO jj = 2, jpjm1 - DO ji = fs_2, fs_jpim1 ! vector opt. - pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & - & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) & - & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) - END DO - END DO - END DO + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) & + & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji-1,jj ,jk) ) ) + zslpy(ji,jj,jk) = ( zwy(ji,jj,jk) + zwy(ji ,jj-1,jk) ) & + & * ( 0.25 + SIGN( 0.25_wp, zwy(ji,jj,jk) * zwy(ji ,jj-1,jk) ) ) + END_3D + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !-- Slopes limitation + zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), & + & 2.*ABS( zwx (ji-1,jj,jk) ), & + & 2.*ABS( zwx (ji ,jj,jk) ) ) + zslpy(ji,jj,jk) = SIGN( 1.0_wp, zslpy(ji,jj,jk) ) * MIN( ABS( zslpy(ji,jj ,jk) ), & + & 2.*ABS( zwy (ji,jj-1,jk) ), & + & 2.*ABS( zwy (ji,jj ,jk) ) ) + END_3D + ! NOTE [ comm_cleanup ] : need to change sign to ensure halo 1 - halo 2 compatibility + IF ( nn_hls==1 ) CALL lbc_lnk( 'traadv_mus', zslpx, 'T', -1.0_wp , zslpy, 'T', -1.0_wp ) ! lateral boundary conditions (changed sign) + ! + DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !-- MUSCL horizontal advective fluxes + ! MUSCL fluxes + z0u = SIGN( 0.5_wp, pU(ji,jj,jk) ) + zalpha = 0.5 - z0u + zu = z0u - 0.5 * pU(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) + zzwx = pt(ji+1,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk) + zzwy = pt(ji ,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji ,jj,jk) + zwx(ji,jj,jk) = pU(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) + ! + z0v = SIGN( 0.5_wp, pV(ji,jj,jk) ) + zalpha = 0.5 - z0v + zv = z0v - 0.5 * pV(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) + zzwx = pt(ji,jj+1,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk) + zzwy = pt(ji,jj ,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj ,jk) + zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) + END_3D + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Tracer advective trend + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D ! ! trend diagnostics IF( l_trd ) THEN - CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptb(:,:,:,jn) ) - CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptb(:,:,:,jn) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kbb) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kbb) ) END IF - ! ! "Poleward" heat and salt transports + ! ! "Poleward" heat and salt transports IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) ! ! heat transport IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) ) - ! DRM - output the fluxes of heat and salt as 3D fields. - ! IF( cdtype == 'TRA' .AND. jn == jp_tem ) CALL iom_put( "uocetem3D", rau0_rcp * zwx ) ! advective heat transport in i-direction. - ! IF( cdtype == 'TRA' .AND. jn == jp_sal ) CALL iom_put( "uocesal3D", rau0 * zwx ) ! advective salt transport in i-direction. - ! - ! IF( cdtype == 'TRA' .AND. jn == jp_tem ) CALL iom_put( "vocetem3D", rau0_rcp * zwy ) ! advective heat transport in j-direction. - ! IF( cdtype == 'TRA' .AND. jn == jp_sal ) CALL iom_put( "vocesal3D", rau0 * zwy ) ! advective salt transport in j-direction. - ! + ! DRM - output the fluxes of Age and NAge as 3D fields. IF( cdtype == 'TRC' .AND. jn == 1 ) CALL iom_put( "uoceage3D", zwx ) ! advective age transport in i-direction. IF( cdtype == 'TRC' .AND. jn == 2 ) CALL iom_put( "uocenag3D", zwx ) ! advective northern boundary age transport in i-direction. @@ -226,61 +203,46 @@ SUBROUTINE tra_adv_mus( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & ! !-- first guess of the slopes zwx(:,:, 1 ) = 0._wp ! surface & bottom boundary conditions zwx(:,:,jpk) = 0._wp - DO jk = 2, jpkm1 ! interior values - zwx(:,:,jk) = tmask(:,:,jk) * ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) - END DO + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! interior values + zwx(ji,jj,jk) = tmask(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + END_3D ! !-- Slopes of tracer zslpx(:,:,1) = 0._wp ! surface values - DO jk = 2, jpkm1 ! interior value - DO jj = 1, jpj - DO ji = 1, jpi - zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) & - & * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) - END DO - END DO - END DO - DO jk = 2, jpkm1 !-- Slopes limitation - DO jj = 1, jpj ! interior values - DO ji = 1, jpi - zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), & - & 2.*ABS( zwx (ji,jj,jk+1) ), & - & 2.*ABS( zwx (ji,jj,jk ) ) ) - END DO - END DO - END DO - DO jk = 1, jpk-2 !-- vertical advective flux - DO jj = 2, jpjm1 - DO ji = fs_2, fs_jpim1 ! vector opt. - z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) - zalpha = 0.5 + z0w - zw = z0w - 0.5 * pwn(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w_n(ji,jj,jk+1) - zzwx = ptb(ji,jj,jk+1,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) - zzwy = ptb(ji,jj,jk ,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk ) - zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) * wmask(ji,jj,jk) - END DO - END DO - END DO + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) & + & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) + END_3D + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !-- Slopes limitation + zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), & + & 2.*ABS( zwx (ji,jj,jk+1) ), & + & 2.*ABS( zwx (ji,jj,jk ) ) ) + END_3D + DO_3D( 0, 0, 0, 0, 1, jpk-2 ) !-- vertical advective flux + z0w = SIGN( 0.5_wp, pW(ji,jj,jk+1) ) + zalpha = 0.5 + z0w + zw = z0w - 0.5 * pW(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w(ji,jj,jk+1,Kmm) + zzwx = pt(ji,jj,jk+1,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) + zzwy = pt(ji,jj,jk ,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk ) + zwx(ji,jj,jk+1) = pW(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) * wmask(ji,jj,jk) + END_3D IF( ln_linssh ) THEN ! top values, linear free surface only IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) - DO jj = 1, jpj - DO ji = 1, jpi - zwx(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) - END DO - END DO + DO_2D( 0, 0, 0, 0 ) + zwx(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) + END_2D ELSE ! no cavities: only at the ocean surface - zwx(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) + DO_2D( 0, 0, 0, 0 ) + zwx(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) + END_2D ENDIF ENDIF ! - DO jk = 1, jpkm1 !-- vertical advective trend - DO jj = 2, jpjm1 - DO ji = fs_2, fs_jpim1 ! vector opt. - pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) - END DO - END DO - END DO + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- vertical advective trend + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D ! ! send trends for diagnostic - IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_zad, zwx, pwn, ptb(:,:,:,jn) ) + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwx, pW, pt(:,:,:,jn,Kbb) ) ! END DO ! end of tracer loop ! diff --git a/MY_SRC/lapack.F90 b/MY_SRC/usr_def/lapack.F90 similarity index 100% rename from MY_SRC/lapack.F90 rename to MY_SRC/usr_def/lapack.F90 diff --git a/MY_SRC/splines.F90 b/MY_SRC/usr_def/splines.F90 similarity index 100% rename from MY_SRC/splines.F90 rename to MY_SRC/usr_def/splines.F90 diff --git a/MY_SRC/types.F90 b/MY_SRC/usr_def/types.F90 similarity index 100% rename from MY_SRC/types.F90 rename to MY_SRC/usr_def/types.F90 diff --git a/MY_SRC/utils.F90 b/MY_SRC/usr_def/utils.F90 similarity index 100% rename from MY_SRC/utils.F90 rename to MY_SRC/usr_def/utils.F90 diff --git a/arch/nemo/arch-archer2.fcm b/arch/nemo/arch-archer2.fcm index 2399de7..ae95fe4 100644 --- a/arch/nemo/arch-archer2.fcm +++ b/arch/nemo/arch-archer2.fcm @@ -61,3 +61,4 @@ %CC cc %CFLAGS -O0 +ld::tool::fc_modsearch -J diff --git a/arch/xios/arch-archer2.fcm b/arch/xios/arch-archer2.fcm index 4f5d6da..a05014d 100644 --- a/arch/xios/arch-archer2.fcm +++ b/arch/xios/arch-archer2.fcm @@ -22,3 +22,4 @@ %CPP CC -EP %FPP cpp -P %MAKE gmake +bld::tool::fc_modsearch -J diff --git a/scripts/setup/ORCHESTRA_setup b/scripts/setup/ORCHESTRA_setup index 36bdd6c..9683c2e 100755 --- a/scripts/setup/ORCHESTRA_setup +++ b/scripts/setup/ORCHESTRA_setup @@ -3,16 +3,17 @@ display_usage() { echo - echo " Auto-Config: ORCHESTRA on ARCHER" + echo " Auto-Config: ORCHESTRA on ARCHER2" echo " ***************************************" echo - echo " usage: ${0##*/} -w path_to_install_nemo -x path_to_intall_xios -s path_to_repo -m machine -v version" + echo " usage: ${0##*/} -w path_to_install_nemo -x path_to_intall_xios -s path_to_repo -m machine -v version -c commit_SHA" echo echo " flags: -w full path to where nemo will be installed" echo " -x full path to where xios will be installed" echo " -s full path to where the ORCHESTRA repository resides" echo " -m machine on which to compile code" echo " -v which version of NEMO to check out" + echo " -c commit SHA to check out" echo exit 1 } @@ -35,7 +36,11 @@ display_usage() { exit 0 fi -while getopts w:x:s:m:v: option +BRANCH=main +# SHA from 18/07/2022 +COMMIT=cabbd8219653b4609b62cdf8ec6581cceb9bcbff + +while getopts w:x:s:m:v:c: option do case "${option}" in @@ -43,7 +48,8 @@ while getopts w:x:s:m:v: option x) export XIOS_DIR=${OPTARG};; s) export REPO_DIR=${OPTARG};; m) export HPC_TARG=${OPTARG};; - v) export NEMO_VER=${OPTARG};; + b) export BRANCH=${OPTARG};; + c) export COMMIT=${OPTARG};; esac done @@ -82,42 +88,37 @@ esac # Checkout the NEMO code from the SVN Paris repository echo "Checking out NEMO repository" -case "${NEMO_VER}" - in - 4.0.6) echo "NEMO Verion 4.0.6 will be checked out" - ;; - *) echo "NEMO Version not recognised" - echo "Versions available at present: 4.0.6" - exit 1 -esac +# case "${NEMO_VER}" +# in +# 4.0.6) echo "NEMO Verion 4.0.6 will be checked out" +# ;; +# *) echo "NEMO Version not recognised" +# echo "Versions available at present: 4.0.6" +# exit 1 +# esac # Checkout the NEMO code from the SVN Paris repository +# Checkout as per https://github.com/immerse-project/wp6.2-demonstrator/blob/main/scripts/setup echo "Checking out NEMO repository" -case "${NEMO_VER}" - in - trunk) svn co http://forge.ipsl.jussieu.fr/nemo/svn/NEMO/trunk --depth empty nemo - svn co http://forge.ipsl.jussieu.fr/nemo/svn/NEMO/trunk/src --depth infinity nemo/src - svn co http://forge.ipsl.jussieu.fr/nemo/svn/NEMO/trunk/cfgs/SHARED nemo/cfgs/SHARED - svn export http://forge.ipsl.jussieu.fr/nemo/svn/NEMO/trunk/cfgs/ref_cfgs.txt nemo/cfgs/ref_cfgs.txt - ;; - *) svn co http://forge.ipsl.jussieu.fr/nemo/svn/NEMO/releases/r4.0/r$NEMO_VER --depth empty nemo - svn co http://forge.ipsl.jussieu.fr/nemo/svn/NEMO/releases/r4.0/r$NEMO_VER/src --depth infinity nemo/src - svn co http://forge.ipsl.jussieu.fr/nemo/svn/NEMO/releases/r4.0/r$NEMO_VER/cfgs/SHARED nemo/cfgs/SHARED - svn export http://forge.ipsl.jussieu.fr/nemo/svn/NEMO/releases/r4.0/r$NEMO_VER/cfgs/ref_cfgs.txt nemo/cfgs/ref_cfgs.txt - ;; -esac +git clone https://forge.nemo-ocean.eu/nemo/nemo.git -b "$BRANCH" "$NEMODIR" || exit +if [ -n "${COMMIT}" ]; then + cd "$NEMODIR" || exit + git reset --hard "$COMMIT" || exit + cd "$WD" || exit +fi cd nemo -# Now check EXTERNALS revision number before checking out the rest -for ext_name in mk FCM IOIPSL - do - ext=`svn propget svn:externals | grep $ext_name | cut -c2-` - svn co http://forge.ipsl.jussieu.fr/nemo/svn/$ext -done +# External snippet below is no longer required as ext is included in the git repo now @jdha +## Now check EXTERNALS revision number before checking out the rest +#for ext_name in mk FCM IOIPSL +# do +# ext=`svn propget svn:externals | grep $ext_name | cut -c2-` +# svn co http://forge.ipsl.jussieu.fr/nemo/svn/$ext +#done -ext=`svn propget svn:externals | grep makenemo | cut -c2-` -svn export http://forge.ipsl.jussieu.fr/nemo/svn/$ext +#ext=`svn propget svn:externals | grep makenemo | cut -c2-` +#svn export http://forge.ipsl.jussieu.fr/nemo/svn/$ext mkdir arch @@ -135,34 +136,39 @@ fi cd $XIOS_DIR echo $PWD echo "Checking out xios repository" -case "${NEMO_VER}" - in - 4.0.2) svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios - ;; - 4.0.3) svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios - ;; - 4.0.4) svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios - ;; - 4.0.5) svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios - ;; - 4.0.6) svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios - ;; - trunk) svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios - ;; - *) echo "NEMO Version not recognised" - echo "Versions available: 4.0.2, 4.0.3, 4.0.4, 4.0.5, 4.0.6 and trunk" - exit 1 -esac +svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/trunk xios + +# Not required for v4.2 +# case "${NEMO_VER}" +# in +# 4.0.2) svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios +# ;; +# 4.0.3) svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios +# ;; +# 4.0.4) svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios +# ;; +# 4.0.5) svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios +# ;; +# 4.0.6) svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios +# ;; +# trunk) svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios +# ;; +# *) echo "NEMO Version not recognised" +# echo "Versions available: 4.0.2, 4.0.3, 4.0.4, 4.0.5, 4.0.6 and trunk" +# exit 1 +# esac + cd xios cp $REPO_DIR/arch/xios/* ./arch echo "Compiling xios" -./make_xios --full --prod --arch archer2 --netcdf_lib netcdf4_par --job 4 +./make_xios --full --prod --arch archer2 --netcdf_lib netcdf4_par --job 16 +# next lines should be redundant after modsearch fix to xios arch file # Dirty fix here as xios has to unpack before we can edit -sed -e "s/FC_MODSEARCH => '', /FC_MODSEARCH => '-J',/" tools/FCM/lib/Fcm/Config.pm > tmp_file -mv tmp_file tools/FCM/lib/Fcm/Config.pm +#sed -e "s/FC_MODSEARCH => '', /FC_MODSEARCH => '-J',/" tools/FCM/lib/Fcm/Config.pm > tmp_file +#mv tmp_file tools/FCM/lib/Fcm/Config.pm # Try once more -./make_xios --full --prod --arch archer2 --netcdf_lib netcdf4_par --job 4 +#./make_xios --full --prod --arch archer2 --netcdf_lib netcdf4_par --job 16 # Let's update the path to xios export XIOS_DIR=$XIOS_DIR/xios @@ -245,9 +251,10 @@ wget -r -nd -np -e robots=off -A '*.nc' http://gws-access.jasmin.ac.uk/public/jm wget -r -nd -np -e robots=off -A 'name*' http://gws-access.jasmin.ac.uk/public/jmmp_collab/ORCHESTRA/INPUTS/ -P $CONFIG_DIR/INPUTS/ wget -r -nd -np -e robots=off -A '*.nc' http://gws-access.jasmin.ac.uk/public/jmmp_collab/ORCHESTRA/FORCING/ -P $CONFIG_DIR/FORCING/ -cd $WORK_DIR/nemo/ext/FCM/lib/Fcm -sed -e "s/FC_MODSEARCH => '', /FC_MODSEARCH => '-J',/" Config.pm > tmp_file -mv tmp_file Config.pm +# next lines should be redundant after modsearch fix to nemo arch file +#cd $WORK_DIR/nemo/ext/FCM/lib/Fcm +#sed -e "s/FC_MODSEARCH => '', /FC_MODSEARCH => '-J',/" Config.pm > tmp_file +#mv tmp_file Config.pm cd $WORK_DIR/nemo mkdir $CONFIG_DIR/EXPREF @@ -257,15 +264,15 @@ cp -rP $REPO_DIR/EXP_SZT/* $CONFIG_DIR/EXP_SZT cp -rP $REPO_DIR/EXP_ZPS/* $CONFIG_DIR/EXP_ZPS echo "Compiling nemo ORCHESTRA Config INIT" -./makenemo -m $HPC_TARG -r CORE2NYF-ORCH0083-LIM3 -j 8 -cp cfgs/CORE2NYF-ORCH0083-LIM3/EXP00/opa CORE2NYF-ORCH0083-LIM3/EXPREF/opa_init +./makenemo -m $HPC_TARG -r CORE2NYF-ORCH0083-LIM3 -j 16 +cp cfgs/CORE2NYF-ORCH0083-LIM3/EXP00/nemo CORE2NYF-ORCH0083-LIM3/EXPREF/nemo_init rm CORE2NYF-ORCH0083-LIM3/cpp_CORE2NYF-ORCH0083-LIM3.fcm ln -s cpp_CORE2NYF-ORCH0083-LIM3_SPIN.fcm CORE2NYF-ORCH0083-LIM3/cpp_CORE2NYF-ORCH0083-LIM3.fcm echo "Compiling nemo ORCHESTRA Config MAIN" -./makenemo -m $HPC_TARG -r CORE2NYF-ORCH0083-LIM3 -j 8 clean -./makenemo -m $HPC_TARG -r CORE2NYF-ORCH0083-LIM3 -j 8 -cp CORE2NYF-ORCH0083-LIM3/EXP00/opa CORE2NYF-ORCH0083-LIM3/EXPREF/opa_main +./makenemo -m $HPC_TARG -r CORE2NYF-ORCH0083-LIM3 -j 16 clean +./makenemo -m $HPC_TARG -r CORE2NYF-ORCH0083-LIM3 -j 16 +cp CORE2NYF-ORCH0083-LIM3/EXP00/nemo CORE2NYF-ORCH0083-LIM3/EXPREF/nemo_main echo echo " Auto-Config: ORCHESTRA"