source: NEMO/releases/release-3.6/NEMOGCM/NEMO/OPA_SRC/IOM/iom_rstdimg.F90

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

First attempt to put dynamic allocation on the trunk

  • Property svn:keywords set to Id
File size: 28.2 KB
Line 
1MODULE iom_rstdimg
2   !!=====================================================================
3   !!                    ***  MODULE  iom_rstdimg ***
4   !! Input/Output manager :  Library to read input rstdimg files
5   !!====================================================================
6   !! History :  9.0  ! 06 09  (S. Masson) Original code
7   !!--------------------------------------------------------------------
8
9   !!--------------------------------------------------------------------
10   !!   iom_open       : open a file read only
11   !!   iom_close      : close a file or all files opened by iom
12   !!   iom_get        : read a field (interfaced to several routines)
13   !!   iom_gettime    : read the time axis kvid in the file
14   !!   iom_varid      : get the id of a variable in a file
15   !!   iom_rstput     : write a field in a restart file (interfaced to several routines)
16   !!--------------------------------------------------------------------
17   USE in_out_manager  ! I/O manager
18   USE lib_mpp         ! MPP library
19   USE dom_oce         ! ocean space and time domain
20   USE lbclnk          ! lateal boundary condition / mpp exchanges
21   USE iom_def         ! iom variables definitions
22
23   IMPLICIT NONE
24   PRIVATE
25
26   PUBLIC iom_rstdimg_open, iom_rstdimg_close, iom_rstdimg_get, iom_rstdimg_rstput
27
28   INTERFACE iom_rstdimg_get
29      MODULE PROCEDURE iom_rstdimg_g0d, iom_rstdimg_g123d
30   END INTERFACE
31   INTERFACE iom_rstdimg_rstput
32      MODULE PROCEDURE iom_rstdimg_rp0d, iom_rstdimg_rp123d
33   END INTERFACE
34
35   INTEGER, PARAMETER ::   jpvnl          = 32   ! variable name length
36     
37   !!----------------------------------------------------------------------
38   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
39   !! $Id$
40   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
41   !!----------------------------------------------------------------------
42
43CONTAINS
44
45   SUBROUTINE iom_rstdimg_open( cdname, kiomid, ldwrt, ldok, kdompar )
46      !!---------------------------------------------------------------------
47      !!                   ***  SUBROUTINE  iom_open  ***
48      !!
49      !! ** Purpose :  open an input file read only (return 0 if not found)
50      !!---------------------------------------------------------------------
51      CHARACTER(len=*)       , INTENT(inout)           ::   cdname      ! File name
52      INTEGER                , INTENT(  out)           ::   kiomid      ! iom identifier of the opened file
53      LOGICAL                , INTENT(in   )           ::   ldwrt       ! read or write the file?
54      LOGICAL                , INTENT(in   )           ::   ldok        ! check the existence
55      INTEGER, DIMENSION(2,5), INTENT(in   ), OPTIONAL ::   kdompar     ! domain parameters:
56
57      CHARACTER(LEN=100)                      ::   clinfo                     ! info character
58      CHARACTER(LEN=100)                      ::   cltmp                      ! temporary character
59      CHARACTER(LEN=10 )                      ::   clstatus                   ! status of opened file (REPLACE or NEW)
60      INTEGER                                 ::   jv                         ! loop counter
61      INTEGER                                 ::   istop                      ! temporary storage of nstop
62      INTEGER                                 ::   idrst                      ! logical unit of the restart file
63      INTEGER                                 ::   iln                        ! lengths of character
64      INTEGER                                 ::   irecl8                     ! record length
65      INTEGER                                 ::   ios                        ! IO status
66      INTEGER                                 ::   irhd                       ! record of the header infos
67      INTEGER                                 ::   ivnum                      ! number of variables
68      INTEGER                                 ::   ishft                      ! counter shift
69      INTEGER                                 ::   inx, iny, inz              ! x,y,z dimension of the variable
70      INTEGER                                 ::   in0d, in1d, in2d, in3d     ! number of 0/1/2/3D variables
71      INTEGER                                 ::   ipni, ipnj, ipnij, iarea   ! domain decomposition
72      INTEGER                                 ::   iiglo, ijglo               ! domain global size
73      INTEGER                                 ::   jl                         ! loop variable
74      LOGICAL                                 ::   llclobber                  ! local definition of ln_clobber
75      CHARACTER(LEN=jpvnl), DIMENSION(jpmax_vars) ::   clna0d, clna1d, clna2d, clna3d     ! name of 0/1/2/3D variables
76      REAL(wp),             DIMENSION(jpmax_vars) ::   zval0d, zval1d, zval2d, zval3d     ! value of 0d variables or record
77      !                                                                                   ! position for 1/2/3D variables
78      !---------------------------------------------------------------------
79      clinfo = '                    iom_rstdimg_open ~~~  '
80      istop = nstop      ! store the actual value of nstop
81      ios = 0            ! default definition
82      kiomid = 0         ! default definition
83      llclobber = ldwrt .AND. ln_clobber
84      ! get a free unit
85      idrst = get_unit()  ! get a free logical unit for the restart file
86!!$#if defined key_agrif
87!!$      idrst = Agrif_Get_Unit()     
88!!$#endif
89      ! Open the file...
90      ! =============
91      IF( ldok .AND. .NOT. llclobber ) THEN      ! Open existing file...
92         ! find the record length
93         OPEN( idrst, FILE = TRIM(cdname), FORM = 'unformatted', ACCESS = 'direct'   &
94            &       , RECL = 8, STATUS = 'old', ACTION = 'read', IOSTAT = ios, ERR = 987 )
95         READ( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8
96         CLOSE( idrst )
97         ! Open the file with the appropriate record length and parameters
98         IF( ldwrt ) THEN  ! ... in readwrite mode
99            IF(lwp) WRITE(numout,*) TRIM(clinfo)//' open existing file: '//TRIM(cdname)//' in READWRITE mode'
100            OPEN( idrst, FILE = TRIM(cdname), FORM = 'unformatted', ACCESS = 'direct'   &
101               &       , RECL = irecl8, STATUS = 'old', ACTION = 'readwrite', IOSTAT = ios, ERR = 987 )
102         ELSE              ! ... in read mode
103            IF(lwp) WRITE(numout,*) TRIM(clinfo)//' open existing file: '//TRIM(cdname)//' in READ mode'
104            OPEN( idrst, FILE = TRIM(cdname), FORM = 'unformatted', ACCESS = 'direct'   &
105               &       , RECL = irecl8, STATUS = 'old', ACTION = 'read'     , IOSTAT = ios, ERR = 987 )
106         ENDIF
107      ELSE                                       ! the file does not exist (or we overwrite it)
108         iln = INDEX( cdname, '.dimg' )
109         IF( ldwrt ) THEN  ! the file should be open in readwrite mode so we create it...
110            irecl8= MAX( kdompar(1,1) * kdompar(2,1) * wp, ( 8*jpnij + 15 ) * 4 )
111            IF( jpnij > 1 ) THEN
112               WRITE(cltmp,'(a,a,i4.4,a)') cdname(1:iln-1), '_', narea, '.dimg'
113               cdname = TRIM(cltmp)
114            ENDIF
115            IF(lwp) WRITE(numout,*) TRIM(clinfo)//' create new file: '//TRIM(cdname)//' in READWRITE mode'
116           
117            IF( llclobber ) THEN   ;   clstatus = 'REPLACE' 
118            ELSE                   ;   clstatus = 'NEW'
119            ENDIF
120            OPEN( idrst, FILE = TRIM(cdname), FORM = 'UNFORMATTED', ACCESS = 'DIRECT'   &
121               &       , RECL = irecl8, STATUS = TRIM(clstatus), ACTION = 'readwrite', IOSTAT = ios, ERR = 987 )
122         ELSE              ! the file should be open for read mode so it must exist...
123            CALL ctl_stop( TRIM(clinfo), ' should be impossible case...' )
124         ENDIF
125      ENDIF
126      ! Performs checks on the file
127      ! =============
128      IF( ldok .AND. .NOT. llclobber ) THEN      ! old file
129         READ( idrst, REC = 1   , IOSTAT = ios, ERR = 987 )              &
130              &   irecl8, inx, iny, inz, in0d, in1d, in2d, in3d, irhd,   &
131              &   ipni, ipnj, ipnij, iarea, iiglo, ijglo
132         READ( idrst, REC = irhd, IOSTAT = ios, ERR = 987 )                       &
133            &   clna0d(1:in0d), zval0d(1:in0d), clna1d(1:in1d), zval1d(1:in1d),   &
134            &   clna2d(1:in2d), zval2d(1:in2d), clna3d(1:in3d), zval3d(1:in3d)
135         clinfo = TRIM(clinfo)//' file '//TRIM(cdname)
136         IF( iiglo /= jpiglo       )   CALL ctl_stop( TRIM(clinfo), 'Mismatch in global domain size in i direction' )
137         IF( ijglo /= jpjglo       )   CALL ctl_stop( TRIM(clinfo), 'Mismatch in global domain size in j direction' )
138         IF( ldwrt ) THEN
139            IF( inx   /= kdompar(1,1) )   CALL ctl_stop( TRIM(clinfo), 'Mismatch in local domain size in i direction' )
140            IF( iny   /= kdompar(2,1) )   CALL ctl_stop( TRIM(clinfo), 'Mismatch in local domain size in j direction' )
141         ENDIF
142         IF( inz   /= jpk          )   CALL ctl_stop( TRIM(clinfo), 'Mismatch in domain size in k direction' )
143         IF( ipni  /= jpni         )   CALL ctl_stop( TRIM(clinfo), 'Processor splitting changed along I' )
144         IF( ipnj  /= jpnj         )   CALL ctl_stop( TRIM(clinfo), 'Processor splitting changed along J' )
145         IF( ipnij /= jpnij        )   CALL ctl_stop( TRIM(clinfo), 'Total number of processors changed' )
146         IF( iarea /= narea        )   CALL ctl_stop( TRIM(clinfo), 'Mismatch in area numbering ...' )
147      ENDIF
148      ! fill file informations
149      ! =============
150      IF( istop == nstop ) THEN   ! no error within this routine
151!does not work with some compilers         kiomid = MINLOC(iom_file(:)%nfid, dim = 1)
152         kiomid = 0
153         DO jl = jpmax_files, 1, -1
154            IF( iom_file(jl)%nfid == 0 )   kiomid = jl
155         ENDDO
156         iom_file(kiomid)%name    = TRIM(cdname)
157         iom_file(kiomid)%nfid    = idrst
158         iom_file(kiomid)%iolib   = jprstdimg
159         iom_file(kiomid)%iduld   = -1
160         IF( ldok ) THEN      ! old file
161            ! read variables informations from the file header
162            IF(  TRIM(clna0d(1)) == 'no0d' )   in0d = 0
163            IF(  TRIM(clna1d(1)) == 'no1d' )   in1d = 0
164            IF(  TRIM(clna2d(1)) == 'no2d' )   in2d = 0
165            IF(  TRIM(clna3d(1)) == 'no3d' )   in3d = 0
166            ivnum = in0d + in1d + in2d + in3d
167            iom_file(kiomid)%nvars            = ivnum
168            iom_file(kiomid)%irec             = 2 + in1d + in2d + inz * in3d
169            iom_file(kiomid)%luld(   1:ivnum) = .FALSE.
170            iom_file(kiomid)%scf(    1:ivnum) = 1.
171            ! scalar variable
172            DO jv = 1, in0d
173               iom_file(kiomid)%cn_var(jv) = TRIM(clna0d(jv))
174               iom_file(kiomid)%nvid(  jv) = 1
175               iom_file(kiomid)%ndims( jv) = 0
176               iom_file(kiomid)%ofs(   jv) = zval0d(jv)   ! warning: trick... we use ofs to store the value
177            END DO
178            ! 1d variable
179            ishft = in0d
180            DO jv = 1, in1d
181               iom_file(kiomid)%cn_var(    ishft + jv) = TRIM(clna1d(jv))
182               iom_file(kiomid)%nvid(      ishft + jv) = zval1d(jv)
183               iom_file(kiomid)%ndims(     ishft + jv) = 1
184               iom_file(kiomid)%dimsz(1  , ishft + jv) = jpk
185               iom_file(kiomid)%ofs(       ishft + jv) = 0.
186            END DO
187            ! 2d variable
188            ishft = in0d + in1d
189            DO jv = 1, in2d
190               iom_file(kiomid)%cn_var(    ishft + jv) = TRIM(clna2d(jv))
191               iom_file(kiomid)%nvid(      ishft + jv) = zval2d(jv)
192               iom_file(kiomid)%ndims(     ishft + jv) = 2
193               iom_file(kiomid)%dimsz(1:2, ishft + jv) = (/ inx, iny /)
194               iom_file(kiomid)%ofs(       ishft + jv) = 0.
195            END DO
196            ! 3d variable
197            ishft = in0d + in1d + in2d 
198            DO jv = 1, in3d
199               iom_file(kiomid)%cn_var(    ishft + jv) = TRIM(clna3d(jv))
200               iom_file(kiomid)%nvid(      ishft + jv) = zval3d(jv)
201               iom_file(kiomid)%ndims(     ishft + jv) = 3
202               iom_file(kiomid)%dimsz(1:3, ishft + jv) = (/ inx, iny, jpk /)
203               iom_file(kiomid)%ofs(       ishft + jv) = 0.
204            END DO
205         ELSE                 ! new file
206            iom_file(kiomid)%nvars = 0
207            iom_file(kiomid)%irec  = 2
208            ! store file informations
209            WRITE( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8, kdompar(:,1), jpk   ! store domain size
210         ENDIF
211      ENDIF
212987   CONTINUE
213      IF( ios /= 0 ) THEN
214         WRITE(ctmp1,*) '           iostat = ', ios
215         CALL ctl_stop( TRIM(clinfo), '   error in opening file '//TRIM(cdname), ctmp1 )
216      ENDIF
217      !
218   END SUBROUTINE iom_rstdimg_open
219
220
221   SUBROUTINE iom_rstdimg_close( kiomid )
222      !!--------------------------------------------------------------------
223      !!                   ***  SUBROUTINE  iom_rstdimg_close  ***
224      !!
225      !! ** Purpose : close an input file
226      !!--------------------------------------------------------------------
227      INTEGER, INTENT(in) ::   kiomid   ! iom identifier of the file to be closed
228      !
229      CHARACTER(LEN=100)                      ::   clinfo                     ! info character
230      INTEGER                                 ::   jv                         ! loop counter
231      INTEGER                                 ::   irecl8                     ! record length
232      INTEGER                                 ::   ios                        ! IO status
233      INTEGER                                 ::   irhd                       ! record of the header infos
234      INTEGER                                 ::   ivnum                      ! number of variables
235      INTEGER                                 ::   idrst                      ! file logical unit
236      INTEGER                                 ::   inx, iny, inz              ! x,y,z dimension of the variable
237      INTEGER                                 ::   in0d, in1d, in2d, in3d     ! number of 0/1/2/3D variables
238      CHARACTER(LEN=jpvnl), DIMENSION(jpmax_vars) ::   clna0d, clna1d, clna2d, clna3d    ! name of 0/1/2/3D variables
239      REAL(wp),          DIMENSION(jpmax_vars) ::   zval0d, zval1d, zval2d, zval3d    ! value of 0d variables or record
240      !                                                                               ! position for 1/2/3D variables
241      !---------------------------------------------------------------------
242      !
243      clinfo = '                    iom_rstdimg_close ~~~  '
244      idrst = iom_file(kiomid)%nfid   ! get back the logical unit of the restart file
245      ! test if we can write in the file (test with INQUIRE gives alsways YES even with read only files...)
246      READ(  idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8, inx, iny, inz   
247      WRITE( idrst, REC = 1, IOSTAT = ios            ) irecl8, inx, iny, inz   
248      ! We can write in the file => we update its header before closing
249      IF( ios == 0 ) THEN
250         READ( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8, inx, iny, inz   ! get back domain size
251         irhd = iom_file(kiomid)%irec
252         ivnum = iom_file(kiomid)%nvars
253         in0d = 0   ;   in1d = 0   ;   in2d = 0   ;   in3d = 0
254         DO jv = 1, ivnum   ! loop on each variable to get its name and value/record position
255            SELECT CASE (iom_file(kiomid)%ndims(jv))
256            CASE (0)   ! scalar variable
257               in0d = in0d + 1
258               clna0d(in0d) = TRIM(iom_file(kiomid)%cn_var(jv))
259               zval0d(in0d) = iom_file(kiomid)%ofs(jv)   ! warning: trick... we use ofs to store the value
260            CASE (1)   ! 1d variable
261               in1d = in1d + 1
262               clna1d(in1d) = TRIM(iom_file(kiomid)%cn_var(jv))
263               zval1d(in1d) = iom_file(kiomid)%nvid(jv)
264            CASE (2)   ! 2d variable
265               in2d = in2d + 1
266               clna2d(in2d) = TRIM(iom_file(kiomid)%cn_var(jv))
267               zval2d(in2d) = iom_file(kiomid)%nvid(jv)
268            CASE (3)   ! 3d variable
269               in3d = in3d + 1
270               clna3d(in3d) = TRIM(iom_file(kiomid)%cn_var(jv))
271               zval3d(in3d) = iom_file(kiomid)%nvid(jv)
272            CASE DEFAULT   ;   CALL ctl_stop( TRIM(clinfo), 'Should not ne there...' )
273            END SELECT
274         END DO
275         ! force to have at least 1 variable in each list (not necessary (?), but safer...)
276         IF( in0d == 0 ) THEN   ;   in0d = 1   ;   clna0d(1) = 'no0d'   ;   zval0d(1) = -1.   ;   ENDIF
277         IF( in1d == 0 ) THEN   ;   in1d = 1   ;   clna1d(1) = 'no1d'   ;   zval1d(1) = -1.   ;   ENDIF
278         IF( in2d == 0 ) THEN   ;   in2d = 1   ;   clna2d(1) = 'no2d'   ;   zval2d(1) = -1.   ;   ENDIF
279         IF( in3d == 0 ) THEN   ;   in3d = 1   ;   clna3d(1) = 'no3d'   ;   zval3d(1) = -1.   ;   ENDIF
280         ! update the file header before closing it
281         WRITE( idrst, REC = 1, IOSTAT = ios, ERR = 987 )              &
282            &   irecl8, inx, iny, inz, in0d, in1d, in2d, in3d, irhd,   &
283            &   jpni, jpnj, jpnij, narea, jpiglo, jpjglo,              &
284            &   nlcit, nlcjt, nldit, nldjt, nleit, nlejt, nimppt, njmppt
285         IF( (ivnum * (jpvnl + wp)) > irecl8 ) THEN
286            CALL ctl_stop( TRIM(clinfo),   &
287                 &   'Last record size is too big... You could reduce the value of jpvnl' )
288         ELSE
289            WRITE( idrst, REC = irhd, IOSTAT = ios, ERR = 987 )                        &
290                 &   clna0d(1:in0d), zval0d(1:in0d), clna1d(1:in1d), zval1d(1:in1d),   &
291                 &   clna2d(1:in2d), zval2d(1:in2d), clna3d(1:in3d), zval3d(1:in3d)
292         ENDIF
293      ELSE
294         ios = 0   ! we cannot write in the file
295      ENDIF
296      !
297      CLOSE( idrst, IOSTAT = ios, ERR = 987 )
298987   CONTINUE
299      IF( ios /= 0 ) THEN
300         WRITE(ctmp1,*) '           iostat = ', ios
301         CALL ctl_stop( TRIM(clinfo),   &
302            &   '   error when updating the header of '//TRIM(iom_file(kiomid)%name), ctmp1 )
303      ENDIF
304      !   
305   END SUBROUTINE iom_rstdimg_close
306
307
308   SUBROUTINE iom_rstdimg_g0d( kiomid, kvid, pvar )
309      !!-----------------------------------------------------------------------
310      !!                  ***  ROUTINE  iom_rstdimg_g0d  ***
311      !!
312      !! ** Purpose : read a scalar with RSTDIMG
313      !!-----------------------------------------------------------------------
314      INTEGER,  INTENT(in   ) ::   kiomid    ! Identifier of the file
315      INTEGER,  INTENT(in   ) ::   kvid      ! variable id
316      REAL(wp), INTENT(  out) ::   pvar      ! read field
317      !---------------------------------------------------------------------
318      !
319      pvar = iom_file(kiomid)%ofs(kvid)   ! warning: trick... we use ofs to store the value
320      !
321   END SUBROUTINE iom_rstdimg_g0d
322
323
324   SUBROUTINE iom_rstdimg_rp0d( kiomid, cdvar, kvid, pv_r0d )
325      !!--------------------------------------------------------------------
326      !!                   ***  SUBROUTINE  iom_rstdimg_rstput  ***
327      !!
328      !! ** Purpose : write a scalar with RSTDIMG
329      !!--------------------------------------------------------------------
330      INTEGER                   , INTENT(in) ::   kiomid   ! Identifier of the file
331      CHARACTER(len=*)          , INTENT(in) ::   cdvar    ! time axis name
332      INTEGER                   , INTENT(in) ::   kvid     ! variable id
333      REAL(wp)                  , INTENT(in) ::   pv_r0d   ! written 0d field
334      !
335      CHARACTER(LEN=100) ::   clinfo     ! info character
336      INTEGER            ::   idvar      ! variable id
337      !---------------------------------------------------------------------
338     
339      clinfo = '                    iom_rstdimg_rp0d ~~~  '
340      IF( kvid <= 0 ) THEN   !   new variable
341         idvar = iom_file(kiomid)%nvars + 1
342      ELSE                   !   the variable already exists in the file
343         idvar = kvid
344      ENDIF
345      IF( idvar <= jpmax_vars ) THEN
346         iom_file(kiomid)%nvars = idvar
347         iom_file(kiomid)%cn_var(idvar) = TRIM(cdvar)
348         iom_file(kiomid)%nvid(   idvar) = 1   ! useless, Od variables a strored in record 1
349         iom_file(kiomid)%ndims(  idvar) = 0
350         iom_file(kiomid)%luld(   idvar) = .FALSE.
351         iom_file(kiomid)%scf(    idvar) = 1.
352         iom_file(kiomid)%ofs(    idvar) = pv_r0d   ! warning: trick... we use ofs to store the value
353      ELSE
354         CALL ctl_stop( TRIM(clinfo), 'increase the value of jpmax_vars' )
355      ENDIF
356   END SUBROUTINE iom_rstdimg_rp0d
357
358
359   SUBROUTINE iom_rstdimg_g123d( kiomid, kdom  , kvid, kx1, kx2, ky1, ky2,   &
360         &                       pv_r1d, pv_r2d, pv_r3d )
361      !!-----------------------------------------------------------------------
362      !!                  ***  ROUTINE  iom_rstdimg_g123d  ***
363      !!
364      !! ** Purpose : read a 1D/2D/3D variable with RSTDIMG
365      !!
366      !! ** Method : read ONE record at each CALL
367      !!-----------------------------------------------------------------------
368      INTEGER                    , INTENT(in   )           ::   kiomid     ! iom identifier of the file
369      INTEGER                    , INTENT(in   )           ::   kdom       ! Type of domain to be read
370      INTEGER                    , INTENT(in   )           ::   kvid       ! variable id
371      INTEGER ,                    INTENT(inout)           ::   kx1, kx2, ky1, ky2   ! subdomain indexes
372      REAL(wp), DIMENSION(:)     , INTENT(  out), OPTIONAL ::   pv_r1d     ! read field (1D case)
373      REAL(wp), DIMENSION(:,:)   , INTENT(  out), OPTIONAL ::   pv_r2d     ! read field (2D case)
374      REAL(wp), DIMENSION(:,:,:) , INTENT(  out), OPTIONAL ::   pv_r3d     ! read field (3D case)
375
376      CHARACTER(LEN=100) ::   clinfo               ! info character
377      INTEGER            ::   ios                  ! IO status
378      INTEGER            ::   jk                   ! loop counter
379      INTEGER            ::   idrst                ! logical unit of the restart file
380      !---------------------------------------------------------------------
381      clinfo = '                    iom_rstdimg_g123d ~~~  '
382      !
383      IF( kdom == jpdom_data .OR. kdom == jpdom_global ) THEN
384         CALL ctl_stop( TRIM(clinfo), TRIM(iom_file(kiomid)%cn_var(kvid))//': case not coded for rstdimg files' )
385      ELSE
386      !
387         idrst = iom_file(kiomid)%nfid   ! get back the logical unit of the restart file
388         ! modify the subdomain indexes because we cannot directly extract the appropriate subdomaine
389         IF(     kdom == jpdom_local_full    ) THEN   ;   kx1 = 1   ;   kx2 = jpi    ;   ky1 = 1
390         ELSEIF( kdom == jpdom_local_noextra ) THEN   ;   kx1 = 1   ;   kx2 = nlci   ;   ky1 = 1
391         ENDIF
392         !
393         IF(     PRESENT(pv_r1d) ) THEN   ! read 1D variables
394            READ(    idrst, REC = iom_file(kiomid)%nvid(kvid)         , IOSTAT = ios, ERR = 987 )   pv_r1d(:)
395         ELSEIF( PRESENT(pv_r2d) ) THEN   ! read 2D variables
396            READ(    idrst, REC = iom_file(kiomid)%nvid(kvid)         , IOSTAT = ios, ERR = 987 )   pv_r2d(kx1:kx2, ky1:ky2    )
397         ELSEIF( PRESENT(pv_r3d) ) THEN   ! read 3D variables
398            DO jk = 1, iom_file(kiomid)%dimsz(3,kvid)   ! do loop on each level
399               READ( idrst, REC = iom_file(kiomid)%nvid(kvid) + jk - 1, IOSTAT = ios, ERR = 987 )   pv_r3d(kx1:kx2, ky1:ky2, jk)
400            END DO
401         ENDIF
402987      CONTINUE
403         IF( ios /= 0 ) THEN
404            WRITE(ctmp1,*) '           iostat = ', ios
405            CALL ctl_stop( TRIM(clinfo), '   IO error with file '//TRIM(iom_file(kiomid)%name), ctmp1 )
406         ENDIF
407      ENDIF
408      !
409   END SUBROUTINE iom_rstdimg_g123d
410
411
412   SUBROUTINE iom_rstdimg_rp123d( kiomid, cdvar, kvid, pv_r1d, pv_r2d, pv_r3d )
413      !!--------------------------------------------------------------------
414      !!                   ***  SUBROUTINE  iom_rstdimg_rstput  ***
415      !!
416      !! ** Purpose : write a 2D/3D variable with RSTDIMG
417      !!--------------------------------------------------------------------
418      INTEGER                         , INTENT(in)           ::   kiomid   ! Identifier of the file
419      CHARACTER(len=*)                , INTENT(in)           ::   cdvar    ! time axis name
420      INTEGER                         , INTENT(in)           ::   kvid     ! variable id
421      REAL(wp), DIMENSION(          :), INTENT(in), OPTIONAL ::   pv_r1d   ! written 1d field
422      REAL(wp), DIMENSION(:  ,:      ), INTENT(in), OPTIONAL ::   pv_r2d   ! written 2d field
423      REAL(wp), DIMENSION(:  ,:  ,:  ), INTENT(in), OPTIONAL ::   pv_r3d   ! written 3d field
424      !
425      CHARACTER(LEN=100)    ::   clinfo               ! info character
426      INTEGER               ::   irecl8               ! reacord length
427      INTEGER               ::   ios                  ! IO status
428      INTEGER               ::   idrst                ! reacord length
429      INTEGER               ::   inx, iny, inz        ! x,y,z dimension of the variable
430      INTEGER               ::   idvar                ! variable id
431      INTEGER               ::   istop                ! temporary storage of nstop
432      INTEGER               ::   irec                 ! record number
433      INTEGER               ::   ix1, ix2, iy1, iy2   ! subdomain indexes
434      INTEGER               ::   jk                   ! loop counter
435      !---------------------------------------------------------------------
436      !
437      clinfo = '          iom_rstdimg_rp123d, file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(cdvar)
438      istop = nstop                   ! store the actual value of nstop
439      irec = iom_file(kiomid)%irec    ! get back the record number of the variable
440      idrst = iom_file(kiomid)%nfid   ! get back the logical unit of the restart file
441      IF( kvid <= 0 ) THEN   !   new variable
442         idvar = iom_file(kiomid)%nvars + 1
443      ELSE                   !   the variable already exists in the file
444         idvar = kvid
445      ENDIF
446      IF( idvar > jpmax_vars )   CALL ctl_stop( TRIM(clinfo), 'increase the value of jpmax_vars' )
447      IF( .NOT. PRESENT(pv_r1d) ) THEN
448         ! find which part of data must be written
449         READ( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8, inx, iny, inz
450         IF(     inx == (nlei - nldi + 1) .AND. iny == (nlej - nldj + 1) ) THEN
451            ix1 = nldi   ;   ix2 = nlei   ;   iy1 = nldj   ;   iy2 = nlej
452         ELSEIF( inx == nlci              .AND. iny == nlcj              ) THEN
453            ix1 = 1      ;   ix2 = nlci   ;   iy1 = 1      ;   iy2 = nlcj
454         ELSEIF( inx == jpi               .AND. iny == jpj               ) THEN
455            ix1 = 1      ;   ix2 = jpi    ;   iy1 = 1      ;   iy2 = jpj
456         ELSE
457            CALL ctl_stop( clinfo, 'should have been an impossible case...' )
458         ENDIF
459      ENDIF
460      IF( istop == nstop ) THEN
461         ! write the data
462         IF(     PRESENT(pv_r1d) ) THEN   ! 1D variable
463            WRITE( idrst, REC = irec            , IOSTAT = ios, ERR = 987 ) pv_r1d(:)
464         ELSEIF( PRESENT(pv_r2d) ) THEN   ! 2D variable
465            WRITE( idrst, REC = irec            , IOSTAT = ios, ERR = 987 ) pv_r2d(ix1:ix2, iy1:iy2    )
466         ELSEIF( PRESENT(pv_r3d) ) THEN   ! 3D variable
467            DO jk = 1, jpk   ! do loop on each level
468               WRITE( idrst, REC = irec + jk - 1, IOSTAT = ios, ERR = 987 ) pv_r3d(ix1:ix2, iy1:iy2, jk)
469            END DO
470         ENDIF
471         ! fill the file informations
472         iom_file(kiomid)%nvars = idvar
473         IF(     PRESENT(pv_r1d) ) THEN
474            iom_file(kiomid)%irec              = irec + 1
475            iom_file(kiomid)%ndims(     idvar) = 1
476            iom_file(kiomid)%dimsz(1  , idvar) = inz
477         ELSEIF( PRESENT(pv_r2d) ) THEN
478            iom_file(kiomid)%irec              = irec + 1
479            iom_file(kiomid)%ndims(     idvar) = 2
480            iom_file(kiomid)%dimsz(1:2, idvar) = (/ inx, iny /)
481         ELSEIF( PRESENT(pv_r3d) ) THEN
482            iom_file(kiomid)%irec              = irec + inz
483            iom_file(kiomid)%ndims(     idvar) = 3
484            iom_file(kiomid)%dimsz(1:3, idvar) = (/ inx, iny, inz /)
485         ENDIF
486         iom_file(kiomid)%cn_var(idvar) = TRIM(cdvar)
487         iom_file(kiomid)%nvid(  idvar) = irec
488         iom_file(kiomid)%luld(  idvar) = .FALSE.
489         iom_file(kiomid)%scf(   idvar) = 1.
490         iom_file(kiomid)%ofs(   idvar) = 0.
491      ENDIF
492987   CONTINUE
493      IF( ios /= 0 ) THEN
494         WRITE(ctmp1,*) '           iostat = ', ios
495         CALL ctl_stop( TRIM(clinfo), '   IO error with file '//TRIM(iom_file(kiomid)%name), ctmp1 )
496      ELSE
497         IF(lwp) WRITE(numout,*) TRIM(clinfo)//' written ok'
498      ENDIF
499      !     
500   END SUBROUTINE iom_rstdimg_rp123d
501
502
503   !!======================================================================
504END MODULE iom_rstdimg
Note: See TracBrowser for help on using the repository browser.