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 trunk/NEMOGCM/NEMO/LIM_SRC_2 – NEMO

source: trunk/NEMOGCM/NEMO/LIM_SRC_2/limwri_2.F90 @ 2760

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