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.
iom_rstdimg.F90 in branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM – NEMO

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM/iom_rstdimg.F90 @ 4401

Last change on this file since 4401 was 3211, checked in by spickles2, 12 years ago

Stephen Pickles, 11 Dec 2011

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