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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
icbclv.F90 in NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/ICB – NEMO

source: NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/ICB/icbclv.F90 @ 12353

Last change on this file since 12353 was 12340, checked in by acc, 4 years ago

Branch 2019/dev_r11943_MERGE_2019. This commit introduces basic do loop macro
substitution to the 2019 option 1, merge branch. These changes have been SETTE
tested. The only addition is the do_loop_substitute.h90 file in the OCE directory but
the macros defined therein are used throughout the code to replace identifiable, 2D-
and 3D- nested loop opening and closing statements with single-line alternatives. Code
indents are also adjusted accordingly.

The following explanation is taken from comments in the new header file:

This header file contains preprocessor definitions and macros used in the do-loop
substitutions introduced between version 4.0 and 4.2. The primary aim of these macros
is to assist in future applications of tiling to improve performance. This is expected
to be achieved by alternative versions of these macros in selected locations. The
initial introduction of these macros simply replaces all identifiable nested 2D- and
3D-loops with single line statements (and adjusts indenting accordingly). Do loops
are identifiable if they comform to either:

DO jk = ....

DO jj = .... DO jj = ...

DO ji = .... DO ji = ...
. OR .
. .

END DO END DO

END DO END DO

END DO

and white-space variants thereof.

Additionally, only loops with recognised jj and ji loops limits are treated; these are:
Lower limits of 1, 2 or fs_2
Upper limits of jpi, jpim1 or fs_jpim1 (for ji) or jpj, jpjm1 or fs_jpjm1 (for jj)

The macro naming convention takes the form: DO_2D_BT_LR where:

B is the Bottom offset from the PE's inner domain;
T is the Top offset from the PE's inner domain;
L is the Left offset from the PE's inner domain;
R is the Right offset from the PE's inner domain

So, given an inner domain of 2,jpim1 and 2,jpjm1, a typical example would replace:

DO jj = 2, jpj

DO ji = 1, jpim1
.
.

END DO

END DO

with:

DO_2D_01_10
.
.
END_2D

similar conventions apply to the 3D loops macros. jk loop limits are retained
through macro arguments and are not restricted. This includes the possibility of
strides for which an extra set of DO_3DS macros are defined.

In the example definition below the inner PE domain is defined by start indices of
(kIs, kJs) and end indices of (kIe, KJe)

#define DO_2D_00_00 DO jj = kJs, kJe ; DO ji = kIs, kIe
#define END_2D END DO ; END DO

TO DO:

Only conventional nested loops have been identified and replaced by this step. There are constructs such as:

DO jk = 2, jpkm1

z2d(:,:) = z2d(:,:) + e3w(:,:,jk,Kmm) * z3d(:,:,jk) * wmask(:,:,jk)

END DO

which may need to be considered.
  • Property svn:keywords set to Id
File size: 9.0 KB
Line 
1MODULE icbclv
2   !!======================================================================
3   !!                       ***  MODULE  icbclv  ***
4   !! Icebergs:  calving routines for iceberg calving
5   !!======================================================================
6   !! History : 3.3.1 !  2010-01  (Martin&Adcroft) Original code
7   !!            -    !  2011-03  (Madec)          Part conversion to NEMO form
8   !!            -    !                            Removal of mapping from another grid
9   !!            -    !  2011-04  (Alderson)       Split into separate modules
10   !!            -    !  2011-05  (Alderson)       budgets into separate module
11   !!----------------------------------------------------------------------
12
13   !!----------------------------------------------------------------------
14   !!   icb_clv_flx   : transfer input flux of ice into iceberg classes
15   !!   icb_clv       : calve icebergs from stored ice
16   !!----------------------------------------------------------------------
17   USE par_oce        ! NEMO parameters
18   USE dom_oce        ! NEMO ocean domain
19   USE phycst         ! NEMO physical constants
20   USE lib_mpp        ! NEMO MPI library, lk_mpp in particular
21   USE lbclnk         ! NEMO boundary exchanges for gridded data
22
23   USE icb_oce        ! iceberg variables
24   USE icbdia         ! iceberg diagnostics
25   USE icbutl         ! iceberg utility routines
26   USE icb_oce        ! iceberg parameters
27
28   IMPLICIT NONE
29   PRIVATE
30
31   PUBLIC   icb_clv_flx  ! routine called in icbstp.F90 module
32   PUBLIC   icb_clv      ! routine called in icbstp.F90 module
33
34   !! * Substitutions
35#  include "do_loop_substitute.h90"
36   !!----------------------------------------------------------------------
37   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
38   !! $Id$
39   !! Software governed by the CeCILL license (see ./LICENSE)
40   !!----------------------------------------------------------------------
41CONTAINS
42
43   SUBROUTINE icb_clv_flx( kt )
44      !!----------------------------------------------------------------------
45      !!                 ***  ROUTINE icb_clv_flx  ***
46      !!
47      !! ** Purpose :   accumulate ice available for calving into class arrays
48      !!
49      !!----------------------------------------------------------------------
50      INTEGER, INTENT(in) ::   kt
51      !
52      REAL(wp)      ::   zcalving_used, zdist, zfact
53      INTEGER       ::   jn, ji, jj                    ! loop counters
54      INTEGER       ::   imx                           ! temporary integer for max berg class
55      LOGICAL, SAVE ::   ll_first_call = .TRUE.
56      !!----------------------------------------------------------------------
57      !
58      ! Adapt calving flux and calving heat flux from coupler for use here
59      ! Use interior mask: so no bergs in overlap areas and convert from km^3/year to kg/s
60      ! this assumes that input is given as equivalent water flux so that pure water density is appropriate
61
62      zfact = ( (1000._wp)**3 / ( NINT(rday) * nyear_len(1) ) ) * rn_rho_bergs
63      berg_grid%calving(:,:) = src_calving(:,:) * zfact * tmask_i(:,:) * tmask(:,:,1)
64
65      ! Heat in units of W/m2, and mask (just in case)
66      berg_grid%calving_hflx(:,:) = src_calving_hflx(:,:) * tmask_i(:,:) * tmask(:,:,1)
67
68      IF( ll_first_call .AND. .NOT. l_restarted_bergs ) THEN      ! This is a hack to simplify initialization
69         ll_first_call = .FALSE.
70         !do jn=1, nclasses
71         !  where (berg_grid%calving==0.) berg_grid%stored_ice(:,:,jn)=0.
72         !end do
73         DO_2D_00_00
74            IF( berg_grid%calving(ji,jj) /= 0._wp )                                          &    ! Need units of J
75               berg_grid%stored_heat(ji,jj) = SUM( berg_grid%stored_ice(ji,jj,:) ) *         &    ! initial stored ice in kg
76                  &                   berg_grid%calving_hflx(ji,jj) * e1e2t(ji,jj) / berg_grid%calving(ji,jj)   ! J/s/m2 x m^2
77                  !                                                                                             ! = J/s/calving in kg/s
78         END_2D
79      ENDIF
80
81      ! assume that all calving flux must be distributed even if distribution array does not sum
82      ! to one - this may not be what is intended, but it's what you've got
83      DO_2D_11_11
84         imx = berg_grid%maxclass(ji,jj)
85         zdist = SUM( rn_distribution(1:nclasses) ) / SUM( rn_distribution(1:imx) )
86         DO jn = 1, imx
87            berg_grid%stored_ice(ji,jj,jn) = berg_grid%stored_ice(ji,jj,jn)     &
88               &                           + berg_dt * berg_grid%calving(ji,jj) * rn_distribution(jn) * zdist
89         END DO
90      END_2D
91
92      ! before changing the calving, save the amount we're about to use and do budget
93      zcalving_used = SUM( berg_grid%calving(:,:) )
94      berg_grid%tmp(:,:) = berg_dt * berg_grid%calving_hflx(:,:) * e1e2t(:,:) * tmask_i(:,:)
95      berg_grid%stored_heat (:,:) = berg_grid%stored_heat (:,:) + berg_grid%tmp(:,:)
96      CALL icb_dia_income( kt,  zcalving_used, berg_grid%tmp )
97      !
98   END SUBROUTINE icb_clv_flx
99
100
101   SUBROUTINE icb_clv( kt )
102      !!----------------------------------------------------------------------
103      !!                 ***  ROUTINE icb_clv  ***
104      !!
105      !! ** Purpose :   This routine takes a stored ice field and calves to the ocean,
106      !!                so the gridded array stored_ice has only non-zero entries at selected
107      !!                wet points adjacent to known land based calving points
108      !!
109      !! ** method  : - Look at each grid point and see if there's enough for each size class to calve
110      !!                If there is, a new iceberg is calved.  This happens in the order determined by
111      !!                the class definition arrays (which in the default case is smallest first)
112      !!                Note that only the non-overlapping part of the processor where icebergs are allowed
113      !!                is considered
114      !!----------------------------------------------------------------------
115      INTEGER, INTENT(in) ::   kt
116      INTEGER       ::   ji, jj, jn   ! dummy loop indices
117      INTEGER       ::   icnt, icntmax
118      TYPE(iceberg) ::   newberg
119      TYPE(point)   ::   newpt
120      REAL(wp)      ::   zday, zcalved_to_berg, zheat_to_berg
121      !!----------------------------------------------------------------------
122      !
123      icntmax = 0
124      zday    = REAL(nday_year,wp) + REAL(nsec_day,wp)/86400.0_wp
125      !
126      DO jn = 1, nclasses
127         DO jj = nicbdj, nicbej
128            DO ji = nicbdi, nicbei
129               !
130               icnt = 0
131               !
132               DO WHILE (berg_grid%stored_ice(ji,jj,jn) >= rn_initial_mass(jn) * rn_mass_scaling(jn) )
133                  !
134                  newpt%lon = glamt(ji,jj)         ! at t-point (centre of the cell)
135                  newpt%lat = gphit(ji,jj)
136                  newpt%xi  = REAL( mig(ji), wp )
137                  newpt%yj  = REAL( mjg(jj), wp )
138                  !
139                  newpt%uvel = 0._wp               ! initially at rest
140                  newpt%vvel = 0._wp
141                  !                                ! set berg characteristics
142                  newpt%mass           = rn_initial_mass     (jn)
143                  newpt%thickness      = rn_initial_thickness(jn)
144                  newpt%width          = first_width         (jn)
145                  newpt%length         = first_length        (jn)
146                  newberg%mass_scaling = rn_mass_scaling     (jn)
147                  newpt%mass_of_bits   = 0._wp                          ! no bergy
148                  !
149                  newpt%year   = nyear
150                  newpt%day    = zday
151                  newpt%heat_density = berg_grid%stored_heat(ji,jj) / berg_grid%stored_ice(ji,jj,jn)   ! This is in J/kg
152                  !
153                  CALL icb_utl_incr()
154                  newberg%number(:) = num_bergs(:)
155                  !
156                  CALL icb_utl_add( newberg, newpt )
157                  !
158                  zcalved_to_berg = rn_initial_mass(jn) * rn_mass_scaling(jn)           ! Units of kg
159                  !                                ! Heat content
160                  zheat_to_berg           = zcalved_to_berg * newpt%heat_density             ! Units of J
161                  berg_grid%stored_heat(ji,jj) = berg_grid%stored_heat(ji,jj) - zheat_to_berg
162                  !                                ! Stored mass
163                  berg_grid%stored_ice(ji,jj,jn) = berg_grid%stored_ice(ji,jj,jn) - zcalved_to_berg
164                  !
165                  icnt = icnt + 1
166                  !
167                  CALL icb_dia_calve(ji, jj, jn,  zcalved_to_berg, zheat_to_berg )
168               END DO
169               icntmax = MAX( icntmax, icnt )
170            END DO
171         END DO
172      END DO
173      !
174      DO jn = 1, nclasses
175         CALL lbc_lnk( 'icbclv', berg_grid%stored_ice(:,:,jn), 'T', 1._wp )
176      END DO
177      CALL lbc_lnk( 'icbclv', berg_grid%stored_heat, 'T', 1._wp )
178      !
179      IF( nn_verbose_level > 0 .AND. icntmax > 1 )   WRITE(numicb,*) 'icb_clv: icnt=', icnt,' on', narea
180      !
181   END SUBROUTINE  icb_clv
182
183   !!======================================================================
184END MODULE icbclv
Note: See TracBrowser for help on using the repository browser.