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.
limcons.F90 in trunk/NEMOGCM/NEMO/LIM_SRC_3 – NEMO

source: trunk/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90 @ 2715

Last change on this file since 2715 was 2715, checked in by rblod, 13 years ago

First attempt to put dynamic allocation on the trunk
  • Property svn:keywords set to Id
File size: 6.8 KB
Line 
1MODULE limcons
2   !!======================================================================
3   !!                   ***  MODULE  limcons  ***
4   !! LIM-3 Sea Ice :   conservation check
5   !!======================================================================
6   !! History :   -   ! Original code from William H. Lipscomb, LANL
7   !!            3.0  ! 2004-06  (M. Vancoppenolle)   Energy Conservation
8   !!            4.0  ! 2011-02  (G. Madec)  add mpp considerations
9   !!----------------------------------------------------------------------
10#if defined key_lim3
11   !!----------------------------------------------------------------------
12   !!   'key_lim3' :                                   LIM3 sea-ice model
13   !!----------------------------------------------------------------------
14   !!    lim_cons   :   checks whether energy, mass and salt are conserved
15   !!----------------------------------------------------------------------
16   USE par_ice          ! LIM-3 parameter
17   USE ice              ! LIM-3 variables
18   USE dom_ice          ! LIM-3 domain
19   USE dom_oce          ! ocean domain
20   USE in_out_manager   ! I/O manager
21   USE lib_mpp          ! MPP library
22
23   IMPLICIT NONE
24   PRIVATE
25
26   PUBLIC   lim_column_sum
27   PUBLIC   lim_column_sum_energy
28   PUBLIC   lim_cons_check
29
30   !!----------------------------------------------------------------------
31   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011)
32   !! $Id$
33   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
34   !!----------------------------------------------------------------------
35CONTAINS
36
37   SUBROUTINE lim_column_sum( ksum, pin, pout )
38      !!-------------------------------------------------------------------
39      !!               ***  ROUTINE lim_column_sum ***
40      !!
41      !! ** Purpose : Compute the sum of xin over nsum categories
42      !!
43      !! ** Method  : Arithmetics
44      !!
45      !! ** Action  : Gets xin(ji,jj,jl) and computes xout(ji,jj)
46      !!---------------------------------------------------------------------
47      INTEGER                   , INTENT(in   ) ::   ksum   ! number of categories/layers
48      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pin    ! input field
49      REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   pout   ! output field
50      !
51      INTEGER ::   jl   ! dummy loop indices
52      !!---------------------------------------------------------------------
53      !
54      pout(:,:) = pin(:,:,1)
55      DO jl = 2, ksum
56         pout(:,:) = pout(:,:) + pin(:,:,jl)
57      END DO
58      !
59   END SUBROUTINE lim_column_sum
60
61
62   SUBROUTINE lim_column_sum_energy( ksum, klay, pin, pout)
63      !!-------------------------------------------------------------------
64      !!               ***  ROUTINE lim_column_sum_energy ***
65      !!
66      !! ** Purpose : Compute the sum of xin over nsum categories
67      !!              and nlay layers
68      !!
69      !! ** Method  : Arithmetics
70      !!---------------------------------------------------------------------
71      INTEGER                               , INTENT(in   ) ::   ksum   !: number of categories
72      INTEGER                               , INTENT(in   ) ::   klay   !: number of vertical layers
73      REAL(wp), DIMENSION(jpi,jpj,jkmax,jpl), INTENT(in   ) ::   pin   !: input field
74      REAL(wp), DIMENSION(jpi,jpj)          , INTENT(  out) ::   pout   !: output field
75      !
76      INTEGER ::   jk, jl   ! dummy loop indices
77      !!---------------------------------------------------------------------
78      !
79      DO jl = 1, ksum
80         pout(:,:) = pin(:,:,1,jl)
81         DO jk = 2, klay 
82            pout(:,:) = pout(:,:) + pin(:,:,jk,jl)
83         END DO
84      END DO
85      !
86   END SUBROUTINE lim_column_sum_energy
87
88
89   SUBROUTINE lim_cons_check( px1, px2, pmax_err, cd_fieldid )
90      !!-------------------------------------------------------------------
91      !!               ***  ROUTINE lim_cons_check ***
92      !!
93      !! ** Purpose : Test the conservation of a certain variable
94      !!              For each physical grid cell, check that initial
95      !!              and final values
96      !!              of a conserved field are equal to within a small value.
97      !!
98      !! ** Method  :
99      !!---------------------------------------------------------------------
100      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   px1          !: initial field
101      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   px2          !: final field
102      REAL(wp)                , INTENT(in   ) ::   pmax_err     !: max allowed error
103      CHARACTER(len=15)       , INTENT(in   ) ::   cd_fieldid   !: field identifyer
104      !
105      INTEGER  ::   ji, jj          ! dummy loop indices
106      INTEGER  ::   inb_error       ! number of g.c where there is a cons. error
107      LOGICAL  ::   llconserv_err   ! = .true. if conservation check failed
108      REAL(wp) ::   zmean_error     ! mean error on error points
109      !!---------------------------------------------------------------------
110      !
111      IF(lwp) WRITE(numout,*) ' lim_cons_check '
112      IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~ '
113
114      llconserv_err = .FALSE.
115      inb_error     = 0
116      zmean_error   = 0._wp
117      IF( MAXVAL( px2(:,:) - px1(:,:) ) > pmax_err )   llconserv_err = .TRUE.
118
119      IF( llconserv_err ) THEN
120         DO jj = 1, jpj 
121            DO ji = 1, jpi
122               IF( ABS( px2(ji,jj) - px1(ji,jj) ) > pmax_err ) THEN
123                  inb_error   = inb_error + 1
124                  zmean_error = zmean_error + ABS( px2(ji,jj) - px1(ji,jj) )
125                  !
126                  IF(lwp) THEN
127                     WRITE (numout,*) ' ALERTE 99 '
128                     WRITE (numout,*) ' Conservation error: ', cd_fieldid
129                     WRITE (numout,*) ' Point             : ', ji, jj 
130                     WRITE (numout,*) ' lat, lon          : ', gphit(ji,jj), glamt(ji,jj)
131                     WRITE (numout,*) ' Initial value     : ', px1(ji,jj)
132                     WRITE (numout,*) ' Final value       : ', px2(ji,jj)
133                     WRITE (numout,*) ' Difference        : ', px2(ji,jj) - px1(ji,jj)
134                  ENDIF
135               ENDIF
136            END DO
137         END DO
138         !
139      ENDIF
140      IF(lk_mpp)   CALL mpp_sum( inb_error   )
141      IF(lk_mpp)   CALL mpp_sum( zmean_error )
142      !
143      IF( inb_error > 0 .AND. lwp ) THEN
144         zmean_error = zmean_error / REAL( inb_error, wp )
145         WRITE(numout,*) ' Conservation check for : ', cd_fieldid
146         WRITE(numout,*) ' Number of error points : ', inb_error
147         WRITE(numout,*) ' Mean error on these pts: ', zmean_error
148      ENDIF
149      !
150   END SUBROUTINE lim_cons_check
151
152#else
153   !!----------------------------------------------------------------------
154   !!   Default option         Empty module            NO LIM sea-ice model
155   !!----------------------------------------------------------------------
156#endif
157   !!======================================================================
158END MODULE limcons
Note: See TracBrowser for help on using the repository browser.