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.
limwri_2.F90 in branches/2016/dev_r6519_HPC_4/NEMOGCM/NEMO/LIM_SRC_2 – NEMO

source: branches/2016/dev_r6519_HPC_4/NEMOGCM/NEMO/LIM_SRC_2/limwri_2.F90 @ 7512

Last change on this file since 7512 was 7508, checked in by mocavero, 8 years ago

changes on code duplication and workshare construct
  • Property svn:keywords set to Id
File size: 18.0 KB
Line 
1MODULE limwri_2
2   !!======================================================================
3   !!                     ***  MODULE  limwri_2  ***
4   !!         Ice diagnostics :  write ice output files
5   !!======================================================================
6   !! history :  2.0  ! 2003-08  (C. Ethe)      original code
7   !!            2.0  ! 2004-10  (C. Ethe )     1D configuration
8   !!             -   ! 2009-06  (B. Lemaire )  iom_put + lim_wri_state_2
9   !!-------------------------------------------------------------------
10#if defined key_lim2
11   !!----------------------------------------------------------------------
12   !!   'key_lim2'                                    LIM 2.0 sea-ice model
13   !!----------------------------------------------------------------------
14   !!----------------------------------------------------------------------
15   !!   lim_wri_2       : write of the diagnostics variables in ouput file
16   !!   lim_wri_init_2  : initialization and namelist read
17   !!   lim_wri_state_2 : write for initial state or/and abandon:
18   !!                     > output.init.nc (if ninist = 1 in namelist)
19   !!                     > output.abort.nc
20   !!----------------------------------------------------------------------
21   USE phycst
22   USE dom_oce
23   USE sbc_oce
24   USE sbc_ice
25   USE dom_ice_2
26   USE ice_2
27
28   USE dianam           ! build name of file (routine)
29   USE lbclnk
30   USE in_out_manager
31   USE lib_mpp          ! MPP library
32   USE wrk_nemo         ! work arrays
33   USE iom
34   USE ioipsl
35   USE lib_fortran      ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
36
37   IMPLICIT NONE
38   PRIVATE
39
40#if ! defined key_iomput
41   PUBLIC   lim_wri_2         ! called by sbc_ice_lim_2
42#endif
43   PUBLIC   lim_wri_state_2   ! called by dia_wri_state
44   PUBLIC   lim_wri_alloc_2   ! called by nemogcm.F90
45
46   INTEGER, PARAMETER                       ::   jpnoumax = 40   ! maximum number of variable for ice output
47   INTEGER                                  ::   noumef          ! number of fields
48   REAL(wp)           , DIMENSION(jpnoumax) ::   cmulti ,     &  ! multiplicative constant
49      &                                          cadd            ! additive constant
50   CHARACTER(len = 35), DIMENSION(jpnoumax) ::   titn            ! title of the field
51   CHARACTER(len = 8 ), DIMENSION(jpnoumax) ::   nam             ! name of the field
52   CHARACTER(len = 8 ), DIMENSION(jpnoumax) ::   uni             ! unit of the field
53   INTEGER            , DIMENSION(jpnoumax) ::   nc              ! switch for saving field ( = 1 ) or not ( = 0 )
54
55   INTEGER ::   nice, nhorid, ndim, niter, ndepid       ! ????
56   INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex51   ! ????
57
58   REAL(wp) ::   epsi16 = 1.e-16_wp   ! constant values
59   REAL(wp) ::   zzero  = 0._wp       !     -      -
60   REAL(wp) ::   zone   = 1._wp       !     -      -
61
62   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zcmo      ! Workspace array for netcdf writer.
63
64
65   !! * Substitutions
66#   include "vectopt_loop_substitute.h90"
67   !!----------------------------------------------------------------------
68   !! NEMO/LIM2 3.3 , UCL - NEMO Consortium (2010)
69   !! $Id$
70   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
71   !!----------------------------------------------------------------------
72CONTAINS
73
74   INTEGER FUNCTION lim_wri_alloc_2()
75      !!-------------------------------------------------------------------
76      !!                  ***   ROUTINE lim_wri_alloc_2  ***
77      !!-------------------------------------------------------------------
78      ALLOCATE( ndex51(jpij), zcmo(jpi,jpj,jpnoumax), STAT=lim_wri_alloc_2)
79      !
80      IF( lk_mpp               )   CALL mpp_sum ( lim_wri_alloc_2 )
81      IF( lim_wri_alloc_2 /= 0 )   CALL ctl_warn('lim_wri_alloc_2: failed to allocate array ndex51')
82      !
83   END FUNCTION lim_wri_alloc_2
84
85
86#if ! defined key_iomput
87   SUBROUTINE lim_wri_2( kt )
88      !!-------------------------------------------------------------------
89      !!                    ***   ROUTINE lim_wri_2  ***
90      !!               
91      !! ** Purpose :   write the sea-ice output file in NetCDF
92      !!
93      !! ** Method  :   computes the average of some variables and write
94      !!      it in the NetCDF ouput files
95      !!      CAUTION: the sea-ice time-step must be an integer fraction
96      !!      of a day
97      !!-------------------------------------------------------------------
98      INTEGER, INTENT(in) ::   kt     ! number of iteration
99      !!
100      INTEGER  ::   ji, jj, jf                      ! dummy loop indices
101      CHARACTER(len = 80)  ::   clhstnam, clop
102      REAL(wp) ::   zsto, zjulian, zout,   &  ! temporary scalars
103         &          zindh, zinda, zindb, ztmu
104      REAL(wp), DIMENSION(1)                ::   zdept
105      REAL(wp), POINTER, DIMENSION(:,:)     ::   zfield
106      !!-------------------------------------------------------------------
107
108      CALL wrk_alloc( jpi, jpj, zfield )
109                                                 !--------------------!
110      IF( kt == nit000 ) THEN                    !   Initialisation   !
111         !                                       !--------------------!
112
113         CALL lim_wri_init_2 
114                           
115         zsto     = rdt_ice
116         IF( ln_mskland )   THEN   ;   clop = "ave(only(x))"   ! put 1.e+20 on land (very expensive!!)
117         ELSE                      ;   clop = "ave(x)"         ! no use of the mask value (require less cpu time)
118         ENDIF
119         zout     = nwrite * rdt_ice / nn_fsbc
120         niter    = ( nit000 - 1 ) / nn_fsbc
121         zdept(1) = 0.
122         
123         CALL ymds2ju ( nyear, nmonth, nday, rdt, zjulian )
124         zjulian = zjulian - adatrj   !   set calendar origin to the beginning of the experiment
125         CALL dia_nam ( clhstnam, nwrite, 'icemod' )
126         CALL histbeg ( clhstnam, jpi, glamt, jpj, gphit,    &
127            &           1, jpi, 1, jpj, niter, zjulian, rdt_ice, nhorid, nice , domain_id=nidom, snc4chunks=snc4set)
128         CALL histvert( nice, "deptht", "Vertical T levels", "m", 1, zdept, ndepid, "down")
129         CALL wheneq  ( jpij , tmask(:,:,1), 1, 1., ndex51, ndim)
130         
131         DO jf = 1, noumef
132            IF( nc(jf) == 1 )   CALL histdef( nice, nam(jf), titn(jf), uni(jf), jpi, jpj   &
133               &                                  , nhorid, 1, 1, 1, -99, 32, clop, zsto, zout )
134         END DO
135         CALL histend( nice, snc4set )
136         !
137      ENDIF
138      !                                          !--------------------!
139      !                                          !   Cumulate at kt   !
140      !                                          !--------------------!
141
142      !-- Store instantaneous values in zcmo
143     
144!$OMP PARALLEL
145!$OMP DO schedule(static) private(jj, ji)
146      DO jj = 1, jpj
147         DO ji = 1, jpi
148            zcmo(ji,jj, 1:jpnoumax ) = 0.e0 
149         END DO
150      END DO
151!$OMP DO schedule(static) private(jj,ji,zindh,zinda,zindb,ztmu)
152      DO jj = 2 , jpjm1
153         DO ji = 2 , jpim1   ! NO vector opt.
154            zindh  = MAX( zzero , SIGN( zone , hicif(ji,jj) * (1.0 - frld(ji,jj) ) - 0.10 ) )
155            zinda  = MAX( zzero , SIGN( zone , ( 1.0 - frld(ji,jj) ) - 0.10 ) )
156            zindb  = zindh * zinda
157            ztmu   = MAX( 0.5 * zone , ( tmu(ji,jj) + tmu(ji+1,jj) + tmu(ji,jj+1) + tmu(ji+1,jj+1) ) ) 
158            zcmo(ji,jj,1)  = hsnif (ji,jj)
159            zcmo(ji,jj,2)  = hicif (ji,jj)
160            zcmo(ji,jj,3)  = hicifp(ji,jj)
161            zcmo(ji,jj,4)  = frld  (ji,jj)
162            zcmo(ji,jj,5)  = sist  (ji,jj)
163            zcmo(ji,jj,6)  = fbif  (ji,jj)
164           IF (lk_lim2_vp) THEN
165            zcmo(ji,jj,7)  = zindb * (  u_ice(ji,jj  ) * tmu(ji,jj  ) + u_ice(ji+1,jj  ) * tmu(ji+1,jj  )   &
166                                      + u_ice(ji,jj+1) * tmu(ji,jj+1) + u_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) &
167                                  / ztmu 
168
169            zcmo(ji,jj,8)  = zindb * (  v_ice(ji,jj  ) * tmu(ji,jj  ) + v_ice(ji+1,jj  ) * tmu(ji+1,jj  )   &
170                                      + v_ice(ji,jj+1) * tmu(ji,jj+1) + v_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) &
171                                  / ztmu
172           ELSE
173
174            zcmo(ji,jj,7)  = zindb * (  u_ice(ji,jj  ) * tmu(ji,jj)                       &
175             &                        + u_ice(ji-1,jj) * tmu(ji-1,jj) )                   &
176             &                    / 2.0
177            zcmo(ji,jj,8)  = zindb * (  v_ice(ji,jj  ) * tmv(ji,jj)                       &
178             &                        + v_ice(ji,jj-1) * tmv(ji,jj-1) )                   &
179             &                    / 2.0
180
181           ENDIF
182            zcmo(ji,jj,9)  = sst_m(ji,jj)
183            zcmo(ji,jj,10) = sss_m(ji,jj)
184            zcmo(ji,jj,11) = qns(ji,jj) + qsr(ji,jj)
185            zcmo(ji,jj,12) = qsr(ji,jj)
186            zcmo(ji,jj,13) = qns(ji,jj)
187            ! See thersf for the coefficient
188            zcmo(ji,jj,14) = - sfx (ji,jj) * rday * ( sss_m(ji,jj) + epsi16 ) / soce    !!gm ???
189            zcmo(ji,jj,15) = utau_ice(ji,jj)
190            zcmo(ji,jj,16) = vtau_ice(ji,jj)
191            zcmo(ji,jj,17) = qsr_ice(ji,jj,1)
192            zcmo(ji,jj,18) = qns_ice(ji,jj,1)
193            zcmo(ji,jj,19) = sprecip(ji,jj)
194         END DO
195      END DO
196!$OMP END DO NOWAIT
197!$OMP END PARALLEL
198      !
199      ! Write the netcdf file
200      !
201      niter = niter + 1
202      DO jf = 1 , noumef
203!$OMP PARALLEL DO schedule(static) private(jj,ji)
204         DO jj = 1 , jpj
205            DO ji = 1 , jpi
206               zfield(ji,jj) = zcmo(ji,jj,jf) * cmulti(jf) + cadd(jf) * tmask(ji,jj,1)
207            END DO
208         END DO
209         SELECT CASE ( jf )
210         CASE ( 7, 8, 15, 16, 20, 21 )  ! velocity or stress fields (vectors)
211            CALL lbc_lnk( zfield, 'T', -1. )
212         CASE DEFAULT                   ! scalar fields
213            CALL lbc_lnk( zfield, 'T',  1. )
214         END SELECT
215
216         IF( nc(jf) == 1 )   CALL histwrite( nice, nam(jf), niter, zfield, ndim, ndex51 )
217
218      END DO
219
220      IF( ( nn_fsbc * niter ) >= nitend )   CALL histclo( nice ) 
221
222      CALL wrk_dealloc( jpi, jpj, zfield )
223      !
224   END SUBROUTINE lim_wri_2
225
226   SUBROUTINE lim_wri_init_2
227      !!-------------------------------------------------------------------
228      !!                    ***   ROUTINE lim_wri_init_2  ***
229      !!               
230      !! ** Purpose :   intialisation of LIM sea-ice output
231      !!
232      !! ** Method  : Read the namicewri namelist and check the parameter
233      !!       values called at the first timestep (nit000)
234      !!
235      !! ** input   :   Namelist namicewri
236      !!-------------------------------------------------------------------
237      INTEGER ::   nf      ! ???
238      INTEGER ::   ios     ! Local integer output status for namelist read
239      TYPE FIELD 
240         CHARACTER(len = 35) :: ztitle 
241         CHARACTER(len = 8 ) :: zname         
242         CHARACTER(len = 8 ) :: zunit
243         INTEGER             :: znc   
244         REAL                :: zcmulti 
245         REAL                :: zcadd       
246      END TYPE FIELD
247      TYPE(FIELD) ::  &
248         field_1 , field_2 , field_3 , field_4 , field_5 , field_6 ,   &
249         field_7 , field_8 , field_9 , field_10, field_11, field_12,   &
250         field_13, field_14, field_15, field_16, field_17, field_18,   &
251         field_19
252      TYPE(FIELD) , DIMENSION(jpnoumax) :: zfield
253
254      NAMELIST/namiceout/ noumef, &
255         field_1 , field_2 , field_3 , field_4 , field_5 , field_6 ,   &
256         field_7 , field_8 , field_9 , field_10, field_11, field_12,   &
257         field_13, field_14, field_15, field_16, field_17, field_18,   &
258         field_19
259      !!-------------------------------------------------------------------
260      !
261      IF( lim_wri_alloc_2() /= 0 ) THEN      ! allocate lim_wri arrrays
262         CALL ctl_stop( 'STOP', 'lim_wri_init_2 : unable to allocate standard arrays' )   ;   RETURN
263      ENDIF
264                   
265      REWIND( numnam_ice_ref )              ! Namelist namiceout in reference namelist : Ice outputs
266      READ  ( numnam_ice_ref, namiceout, IOSTAT = ios, ERR = 901)
267901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namiceout in reference namelist', lwp )
268
269      REWIND( numnam_ice_cfg )              ! Namelist namiceout in configuration namelist : Ice outputs
270      READ  ( numnam_ice_cfg, namiceout, IOSTAT = ios, ERR = 902 )
271902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namiceout in configuration namelist', lwp )
272      IF(lwm) WRITE ( numoni, namiceout )
273     
274      zfield( 1) = field_1
275      zfield( 2) = field_2
276      zfield( 3) = field_3
277      zfield( 4) = field_4
278      zfield( 5) = field_5
279      zfield( 6) = field_6
280      zfield( 7) = field_7
281      zfield( 8) = field_8
282      zfield( 9) = field_9
283      zfield(10) = field_10
284      zfield(11) = field_11
285      zfield(12) = field_12
286      zfield(13) = field_13
287      zfield(14) = field_14
288      zfield(15) = field_15
289      zfield(16) = field_16
290      zfield(17) = field_17
291      zfield(18) = field_18
292      zfield(19) = field_19
293     
294      DO nf = 1, noumef
295         titn  (nf) = zfield(nf)%ztitle
296         nam   (nf) = zfield(nf)%zname
297         uni   (nf) = zfield(nf)%zunit
298         nc    (nf) = zfield(nf)%znc
299         cmulti(nf) = zfield(nf)%zcmulti
300         cadd  (nf) = zfield(nf)%zcadd
301      END DO
302
303      IF(lwp) THEN
304         WRITE(numout,*)
305         WRITE(numout,*) 'lim_wri_init_2 : Ice parameters for outputs'
306         WRITE(numout,*) '~~~~~~~~~~~~~~'
307         WRITE(numout,*) '    number of fields to be stored         noumef = ', noumef
308         WRITE(numout,*) '           title                            name     unit      Saving (1/0) ',   &
309            &            '    multiplicative constant       additive constant '
310         DO nf = 1 , noumef         
311            WRITE(numout,*) '   ', titn(nf), '   ', nam(nf),'      ', uni(nf),'  ', nc(nf),'        ', cmulti(nf),   &
312               &       '        ', cadd(nf)
313         END DO
314      ENDIF
315      !   
316   END SUBROUTINE lim_wri_init_2
317
318#endif
319
320   SUBROUTINE lim_wri_state_2( kt, kid, kh_i )
321      !!---------------------------------------------------------------------
322      !!                 ***  ROUTINE lim_wri_state_2  ***
323      !!       
324      !! ** Purpose :   create a NetCDF file named cdfile_name which contains
325      !!      the instantaneous ice state and forcing fields for ice model
326      !!        Used to find errors in the initial state or save the last
327      !!      ocean state in case of abnormal end of a simulation
328      !!
329      !! History :
330      !!   2.0  !  2009-06  (B. Lemaire)
331      !!----------------------------------------------------------------------
332      INTEGER, INTENT( in ) ::   kt               ! ocean time-step index)
333      INTEGER, INTENT( in ) ::   kid , kh_i       
334      !!----------------------------------------------------------------------
335
336      CALL histdef( kid, "isnowthi", "Snow thickness"          , "m"      , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
337      CALL histdef( kid, "iicethic", "Ice thickness"           , "m"      , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
338      CALL histdef( kid, "iiceprod", "Ice produced"            , "m/kt"   , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
339      CALL histdef( kid, "ileadfra", "Ice concentration"       , "-"      , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
340      CALL histdef( kid, "iicetemp", "Ice temperature"         , "K"      , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
341      CALL histdef( kid, "iicevelu", "i-Ice speed (I-point)"   , "m/s"    , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
342      CALL histdef( kid, "iicevelv", "j-Ice speed (I-point)"   , "m/s"    , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
343      CALL histdef( kid, "isstempe", "Sea surface temperature" , "C"      , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
344      CALL histdef( kid, "isssalin", "Sea surface salinity"    , "PSU"    , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
345      CALL histdef( kid, "iicestru", "i-Wind stress over ice (I-pt)", "Pa", jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
346      CALL histdef( kid, "iicestrv", "j-Wind stress over ice (I-pt)", "Pa", jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
347      CALL histdef( kid, "iicesflx", "Solar flux over ice"     , "w/m2"   , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
348      CALL histdef( kid, "iicenflx", "Non-solar flux over ice" , "w/m2"   , jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt )
349      CALL histdef( kid, "isnowpre", "Snow precipitation"      , "kg/m2/s", jpi, jpj, kh_i, 1, 1, 1, -99, 32, "inst(x)", rdt, rdt ) 
350
351      CALL histend( kid, snc4set )   ! end of the file definition
352
353      CALL histwrite( kid, "isnowthi", kt, hsnif          , jpi*jpj, (/1/) )   
354      CALL histwrite( kid, "iicethic", kt, hicif          , jpi*jpj, (/1/) )   
355      CALL histwrite( kid, "iiceprod", kt, hicifp         , jpi*jpj, (/1/) )   
356      CALL histwrite( kid, "ileadfra", kt, 1. - frld(:,:) , jpi*jpj, (/1/) )
357      CALL histwrite( kid, "iicetemp", kt, sist(:,:) - rt0, jpi*jpj, (/1/) )
358      CALL histwrite( kid, "iicevelu", kt, u_ice          , jpi*jpj, (/1/) )
359      CALL histwrite( kid, "iicevelv", kt, v_ice          , jpi*jpj, (/1/) )
360      CALL histwrite( kid, "isstempe", kt, sst_m          , jpi*jpj, (/1/) )
361      CALL histwrite( kid, "isssalin", kt, sss_m          , jpi*jpj, (/1/) )
362      CALL histwrite( kid, "iicestru", kt, utau_ice       , jpi*jpj, (/1/) )
363      CALL histwrite( kid, "iicestrv", kt, vtau_ice       , jpi*jpj, (/1/) )
364      CALL histwrite( kid, "iicesflx", kt, qsr_ice(:,:,1) , jpi*jpj, (/1/) )
365      CALL histwrite( kid, "iicenflx", kt, qns_ice(:,:,1) , jpi*jpj, (/1/) )
366      CALL histwrite( kid, "isnowpre", kt, sprecip        , jpi*jpj, (/1/) )
367
368    END SUBROUTINE lim_wri_state_2
369
370#else
371   !!----------------------------------------------------------------------
372   !!   Default option :         Empty module      NO LIM 2.0 sea-ice model
373   !!----------------------------------------------------------------------
374CONTAINS
375   SUBROUTINE lim_wri_2          ! Empty routine
376   END SUBROUTINE lim_wri_2
377#endif
378
379   !!======================================================================
380END MODULE limwri_2
Note: See TracBrowser for help on using the repository browser.