Changeset 951 for branches/dev_001_GM/NEMO/OFF_SRC/IOM/iom_rstdimg.F90
- Timestamp:
- 2008-05-14T18:42:10+02:00 (16 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/dev_001_GM/NEMO/OFF_SRC/IOM/iom_rstdimg.F90
r719 r951 31 31 MODULE PROCEDURE iom_rstdimg_rp0d, iom_rstdimg_rp123d 32 32 END INTERFACE 33 34 INTEGER, PARAMETER :: jpvnl = 32 ! variable name length 35 33 36 !!---------------------------------------------------------------------- 34 37 !! OPA 9.0 , LOCEAN-IPSL (2006) 35 !! $Header $38 !! $Header: /home/opalod/NEMOCVSROOT/NEMO/OPA_SRC/IOM/iom_rstdimg.F90,v 1.9 2007/06/29 14:10:50 opalod Exp $ 36 39 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 37 40 !!---------------------------------------------------------------------- … … 45 48 !! ** Purpose : open an input file read only (return 0 if not found) 46 49 !!--------------------------------------------------------------------- 47 CHARACTER(len=*) , INTENT(inout) :: cdname ! File name48 INTEGER , INTENT( out) :: kiomid ! iom identifier of the opened file49 LOGICAL , INTENT(in ) :: ldwrt ! read or write the file?50 LOGICAL , INTENT(in ) :: ldok ! check the existence51 INTEGER, DIMENSION(2,5), INTENT(in ) :: kdompar ! domain parameters:50 CHARACTER(len=*) , INTENT(inout) :: cdname ! File name 51 INTEGER , INTENT( out) :: kiomid ! iom identifier of the opened file 52 LOGICAL , INTENT(in ) :: ldwrt ! read or write the file? 53 LOGICAL , INTENT(in ) :: ldok ! check the existence 54 INTEGER, DIMENSION(2,5), INTENT(in ), OPTIONAL :: kdompar ! domain parameters: 52 55 53 56 CHARACTER(LEN=100) :: clinfo ! info character … … 59 62 INTEGER :: irecl8 ! record length 60 63 INTEGER :: ios ! IO status 64 INTEGER :: irhd ! record of the header infos 61 65 INTEGER :: ivnum ! number of variables 62 66 INTEGER :: ishft ! counter shift … … 64 68 INTEGER :: in0d, in1d, in2d, in3d ! number of 0/1/2/3D variables 65 69 INTEGER :: ipni, ipnj, ipnij, iarea ! domain decomposition 66 CHARACTER(LEN=8), DIMENSION(jpmax_vars) :: clna0d, clna1d, clna2d, clna3d ! name of 0/1/2/3D variables 70 INTEGER :: iiglo, ijglo ! domain global size 71 INTEGER :: jl ! loop variable 72 CHARACTER(LEN=jpvnl), DIMENSION(jpmax_vars) :: clna0d, clna1d, clna2d, clna3d ! name of 0/1/2/3D variables 67 73 REAL(wp), DIMENSION(jpmax_vars) :: zval0d, zval1d, zval2d, zval3d ! value of 0d variables or record 68 74 ! ! position for 1/2/3D variables 69 75 !--------------------------------------------------------------------- 70 71 76 clinfo = ' iom_rstdimg_open ~~~ ' 72 77 istop = nstop ! store the actual value of nstop … … 99 104 iln = INDEX( cdname, '.dimg' ) 100 105 IF( ldwrt ) THEN ! the file should be open in readwrite mode so we create it... 101 irecl8= kdompar(1,1) * kdompar(2,1) * wp106 irecl8= MAX( kdompar(1,1) * kdompar(2,1) * wp, ( 8*jpnij + 15 ) * 4 ) 102 107 IF( jpnij > 1 ) THEN 103 WRITE(cltmp,'(a,a,i4.4,a)') cdname(1:iln-1), '_', narea -1, '.dimg'108 WRITE(cltmp,'(a,a,i4.4,a)') cdname(1:iln-1), '_', narea, '.dimg' 104 109 cdname = TRIM(cltmp) 105 110 ENDIF … … 108 113 & , RECL = irecl8, STATUS = 'new', ACTION = 'readwrite', IOSTAT = ios, ERR = 987 ) 109 114 ELSE ! the file should be open for read mode so it must exist... 110 CALL ctl_stop( TRIM(clinfo), ' File '//cdname(1:iln-1)//'* not found' )115 CALL ctl_stop( TRIM(clinfo), ' should be impossible case...' ) 111 116 ENDIF 112 117 ENDIF … … 114 119 ! ============= 115 120 IF( ldok ) THEN ! old file 116 READ( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8, inx, iny, inz, in0d, in1d, in2d, in3d 117 READ( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8, inx, iny, inz, in0d, in1d, in2d, in3d, & 121 READ( idrst, REC = 1 , IOSTAT = ios, ERR = 987 ) & 122 & irecl8, inx, iny, inz, in0d, in1d, in2d, in3d, irhd, & 123 & ipni, ipnj, ipnij, iarea, iiglo, ijglo 124 READ( idrst, REC = irhd, IOSTAT = ios, ERR = 987 ) & 118 125 & clna0d(1:in0d), zval0d(1:in0d), clna1d(1:in1d), zval1d(1:in1d), & 119 & clna2d(1:in2d), zval2d(1:in2d), clna3d(1:in3d), zval3d(1:in3d), & 120 & ipni, ipnj, ipnij, iarea 126 & clna2d(1:in2d), zval2d(1:in2d), clna3d(1:in3d), zval3d(1:in3d) 121 127 clinfo = TRIM(clinfo)//' file '//TRIM(cdname) 122 IF( inx /= kdompar(1,1) ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in domain size in i direction' ) 123 IF( iny /= kdompar(2,1) ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in domain size in j direction' ) 128 IF( iiglo /= jpiglo ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in global domain size in i direction' ) 129 IF( ijglo /= jpjglo ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in global domain size in j direction' ) 130 IF( ldwrt ) THEN 131 IF( inx /= kdompar(1,1) ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in local domain size in i direction' ) 132 IF( iny /= kdompar(2,1) ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in local domain size in j direction' ) 133 ENDIF 124 134 IF( inz /= jpk ) CALL ctl_stop( TRIM(clinfo), 'Mismatch in domain size in k direction' ) 125 135 IF( ipni /= jpni ) CALL ctl_stop( TRIM(clinfo), 'Processor splitting changed along I' ) … … 131 141 ! ============= 132 142 IF( istop == nstop ) THEN ! no error within this routine 133 kiomid = MINLOC(iom_file(:)%nfid, dim = 1) 143 !does not work with some compilers kiomid = MINLOC(iom_file(:)%nfid, dim = 1) 144 kiomid = 0 145 DO jl = jpmax_files, 1, -1 146 IF( iom_file(jl)%nfid == 0 ) kiomid = jl 147 ENDDO 134 148 iom_file(kiomid)%name = TRIM(cdname) 135 149 iom_file(kiomid)%nfid = idrst … … 209 223 INTEGER :: irecl8 ! record length 210 224 INTEGER :: ios ! IO status 225 INTEGER :: irhd ! record of the header infos 211 226 INTEGER :: ivnum ! number of variables 212 227 INTEGER :: idrst ! file logical unit 213 228 INTEGER :: inx, iny, inz ! x,y,z dimension of the variable 214 229 INTEGER :: in0d, in1d, in2d, in3d ! number of 0/1/2/3D variables 215 CHARACTER(LEN= 8), DIMENSION(jpmax_vars) :: clna0d, clna1d, clna2d, clna3d! name of 0/1/2/3D variables216 REAL(wp), DIMENSION(jpmax_vars) :: zval0d, zval1d, zval2d, zval3d! value of 0d variables or record230 CHARACTER(LEN=jpvnl), DIMENSION(jpmax_vars) :: clna0d, clna1d, clna2d, clna3d ! name of 0/1/2/3D variables 231 REAL(wp), DIMENSION(jpmax_vars) :: zval0d, zval1d, zval2d, zval3d ! value of 0d variables or record 217 232 ! ! position for 1/2/3D variables 218 233 !--------------------------------------------------------------------- … … 226 241 IF( ios == 0 ) THEN 227 242 READ( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8, inx, iny, inz ! get back domain size 243 irhd = iom_file(kiomid)%irec 228 244 ivnum = iom_file(kiomid)%nvars 229 245 in0d = 0 ; in1d = 0 ; in2d = 0 ; in3d = 0 … … 249 265 END SELECT 250 266 END DO 251 ! force to have at least 1 va lriable in each list (not necessary (?), but safer)267 ! force to have at least 1 variable in each list (not necessary (?), but safer...) 252 268 IF( in0d == 0 ) THEN ; in0d = 1 ; clna0d(1) = 'no0d' ; zval0d(1) = -1. ; ENDIF 253 269 IF( in1d == 0 ) THEN ; in1d = 1 ; clna1d(1) = 'no1d' ; zval1d(1) = -1. ; ENDIF … … 255 271 IF( in3d == 0 ) THEN ; in3d = 1 ; clna3d(1) = 'no3d' ; zval3d(1) = -1. ; ENDIF 256 272 ! update the file header before closing it 257 WRITE( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) irecl8, inx, iny, inz, in0d, in1d, in2d, in3d, & 258 & clna0d(1:in0d), zval0d(1:in0d), clna1d(1:in1d), zval1d(1:in1d), & 259 & clna2d(1:in2d), zval2d(1:in2d), clna3d(1:in3d), zval3d(1:in3d), & 260 & jpni, jpnj, jpnij, narea, jpiglo, jpjglo, nlcit, nlcjt, nldit, nldjt, nleit, nlejt, nimppt, njmppt 273 WRITE( idrst, REC = 1, IOSTAT = ios, ERR = 987 ) & 274 & irecl8, inx, iny, inz, in0d, in1d, in2d, in3d, irhd, & 275 & jpni, jpnj, jpnij, narea, jpiglo, jpjglo, & 276 & nlcit, nlcjt, nldit, nldjt, nleit, nlejt, nimppt, njmppt 277 IF( (ivnum * (jpvnl + wp)) > irecl8 ) THEN 278 CALL ctl_stop( TRIM(clinfo), & 279 & 'Last record size is too big... You could reduce the value of jpvnl' ) 280 ELSE 281 WRITE( idrst, REC = irhd, IOSTAT = ios, ERR = 987 ) & 282 & clna0d(1:in0d), zval0d(1:in0d), clna1d(1:in1d), zval1d(1:in1d), & 283 & clna2d(1:in2d), zval2d(1:in2d), clna3d(1:in3d), zval3d(1:in3d) 284 ENDIF 261 285 ELSE 262 286 ios = 0 ! we cannot write in the file … … 290 314 291 315 292 SUBROUTINE iom_rstdimg_rp0d( kiomid, cdvar, pv_r0d )316 SUBROUTINE iom_rstdimg_rp0d( kiomid, cdvar, kvid, pv_r0d ) 293 317 !!-------------------------------------------------------------------- 294 318 !! *** SUBROUTINE iom_rstdimg_rstput *** … … 298 322 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 299 323 CHARACTER(len=*) , INTENT(in) :: cdvar ! time axis name 324 INTEGER , INTENT(in) :: kvid ! variable id 300 325 REAL(wp) , INTENT(in) :: pv_r0d ! written 0d field 301 326 ! … … 305 330 ! 306 331 clinfo = ' iom_rstdimg_rp0d ~~~ ' 307 idvar = iom_file(kiomid)%nvars + 1 332 IF( kvid <= 0 ) THEN ! new variable 333 idvar = iom_file(kiomid)%nvars + 1 334 ELSE ! the variable already exists in the file 335 idvar = kvid 336 ENDIF 308 337 IF( idvar <= jpmax_vars ) THEN 309 338 iom_file(kiomid)%nvars = idvar … … 320 349 321 350 322 SUBROUTINE iom_rstdimg_g123d( kiomid, kdom , kvid , kstart, kcount,&323 & 351 SUBROUTINE iom_rstdimg_g123d( kiomid, kdom , kvid, kx1, kx2, ky1, ky2, & 352 & pv_r1d, pv_r2d, pv_r3d ) 324 353 !!----------------------------------------------------------------------- 325 354 !! *** ROUTINE iom_rstdimg_g123d *** … … 332 361 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 333 362 INTEGER , INTENT(in ) :: kvid ! variable id 334 INTEGER , DIMENSION(:) , INTENT(in ) :: kstart ! start position of the reading in each axis 335 INTEGER , DIMENSION(:) , INTENT(in ) :: kcount ! number of points to be read in each axis 363 INTEGER , INTENT(inout) :: kx1, kx2, ky1, ky2 ! subdomain indexes 336 364 REAL(wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 337 365 REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) … … 342 370 INTEGER :: jk ! loop counter 343 371 INTEGER :: idrst ! logical unit of the restart file 344 INTEGER :: istop ! temporary storage of nstop345 INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes346 372 !--------------------------------------------------------------------- 347 373 clinfo = ' iom_rstdimg_g123d ~~~ ' 348 374 ! 349 istop = nstop ! store the actual value of nstop 350 idrst = iom_file(kiomid)%nfid ! get back the logical unit of the restart file 351 IF( kdom == jpdom_data .OR. kdom == jpdom_global ) & 352 & CALL ctl_stop( TRIM(clinfo), TRIM(iom_file(kiomid)%cn_var(kvid))//': case not coded for rstdimg files' ) 353 ! 354 IF( istop == nstop .AND. kvid > 0 ) THEN 355 IF( .NOT. PRESENT(pv_r1d) ) THEN 356 SELECT CASE (kdom) ! find the right index of the array to be read 357 CASE (jpdom_local_full) ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej 358 CASE (jpdom_local_noextra) ; ix1 = 1 ; ix2 = nlci ; iy1 = 1 ; iy2 = nlcj 359 CASE (jpdom_local_noovlap) ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej 360 CASE DEFAULT ; CALL ctl_stop( clinfo, 'we should not be there...' ) 361 END SELECT 362 ENDIF 375 IF( kdom == jpdom_data .OR. kdom == jpdom_global ) THEN 376 CALL ctl_stop( TRIM(clinfo), TRIM(iom_file(kiomid)%cn_var(kvid))//': case not coded for rstdimg files' ) 377 ELSE 378 ! 379 idrst = iom_file(kiomid)%nfid ! get back the logical unit of the restart file 380 ! modify the subdomain indexes because we cannot directly extract the appropriate subdomaine 381 IF( kdom == jpdom_local_full ) THEN ; kx1 = 1 ; kx2 = jpi ; ky1 = 1 382 ELSEIF( kdom == jpdom_local_noextra ) THEN ; kx1 = 1 ; kx2 = nlci ; ky1 = 1 383 ENDIF 384 ! 363 385 IF( PRESENT(pv_r1d) ) THEN ! read 1D variables 364 READ( idrst, REC = iom_file(kiomid)%nvid(kvid), IOSTAT = ios, ERR = 987 ) pv_r1d(:)386 READ( idrst, REC = iom_file(kiomid)%nvid(kvid) , IOSTAT = ios, ERR = 987 ) pv_r1d(:) 365 387 ELSEIF( PRESENT(pv_r2d) ) THEN ! read 2D variables 366 READ( idrst, REC = iom_file(kiomid)%nvid(kvid), IOSTAT = ios, ERR = 987 ) pv_r2d(ix1:ix2, iy1:iy2 ) 367 SELECT CASE (kdom) 368 CASE (jpdom_local_noextra) !--- Fill extra hallows (mpp) 369 pv_r2d(nlci+1:jpi, : ) = 1. 370 pv_r2d( : ,nlcj+1:jpj) = 1. 371 CASE (jpdom_local_noovlap) !--- Fill the overlap areas and extra hallows (mpp) 372 CALL lbc_lnk (pv_r2d,'Z',-999.,'no0') 373 CASE DEFAULT 374 END SELECT 388 READ( idrst, REC = iom_file(kiomid)%nvid(kvid) , IOSTAT = ios, ERR = 987 ) pv_r2d(kx1:kx2, ky1:ky2 ) 375 389 ELSEIF( PRESENT(pv_r3d) ) THEN ! read 3D variables 376 390 DO jk = 1, iom_file(kiomid)%dimsz(3,kvid) ! do loop on each level 377 READ( idrst, REC = iom_file(kiomid)%nvid(kvid) + jk - 1, IOSTAT = ios, ERR = 987 ) & 378 & pv_r3d( ix1:ix2, iy1:iy2, jk ) 379 END DO 380 SELECT CASE (kdom) 381 CASE (jpdom_local_noextra) !--- Fill extra hallows (mpp) 382 pv_r3d(nlci+1:jpi, : ,:) = 1. 383 pv_r3d( : ,nlcj+1:jpj,:) = 1. 384 CASE (jpdom_local_noovlap) !--- Fill the overlap areas and extra hallows (mpp) 385 ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 386 IF( kcount(3) == jpk ) THEN 387 CALL lbc_lnk( pv_r3d,'Z',-999.,'no0' ) 388 ELSE 389 pv_r3d(nlei+1:jpi, : ,:) = 1. 390 pv_r3d( : ,nlej+1:jpj,:) = 1. 391 ENDIF 392 CASE DEFAULT 393 END SELECT 394 ENDIF 395 ENDIF 396 987 CONTINUE 397 IF( ios /= 0 ) THEN 398 WRITE(ctmp1,*) ' iostat = ', ios 399 CALL ctl_stop( TRIM(clinfo), ' IO error with file '//TRIM(iom_file(kiomid)%name), ctmp1 ) 391 READ( idrst, REC = iom_file(kiomid)%nvid(kvid) + jk - 1, IOSTAT = ios, ERR = 987 ) pv_r3d(kx1:kx2, ky1:ky2, jk) 392 END DO 393 ENDIF 394 987 CONTINUE 395 IF( ios /= 0 ) THEN 396 WRITE(ctmp1,*) ' iostat = ', ios 397 CALL ctl_stop( TRIM(clinfo), ' IO error with file '//TRIM(iom_file(kiomid)%name), ctmp1 ) 398 ENDIF 400 399 ENDIF 401 400 ! … … 403 402 404 403 405 SUBROUTINE iom_rstdimg_rp123d( kiomid, cdvar, pv_r1d, pv_r2d, pv_r3d )404 SUBROUTINE iom_rstdimg_rp123d( kiomid, cdvar, kvid, pv_r1d, pv_r2d, pv_r3d ) 406 405 !!-------------------------------------------------------------------- 407 406 !! *** SUBROUTINE iom_rstdimg_rstput *** … … 411 410 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 412 411 CHARACTER(len=*) , INTENT(in) :: cdvar ! time axis name 412 INTEGER , INTENT(in) :: kvid ! variable id 413 413 REAL(wp), DIMENSION( jpk), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field 414 414 REAL(wp), DIMENSION(jpi,jpj ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field … … 431 431 irec = iom_file(kiomid)%irec ! get back the record number of the variable 432 432 idrst = iom_file(kiomid)%nfid ! get back the logical unit of the restart file 433 idvar = iom_file(kiomid)%nvars + 1 433 IF( kvid <= 0 ) THEN ! new variable 434 idvar = iom_file(kiomid)%nvars + 1 435 ELSE ! the variable already exists in the file 436 idvar = kvid 437 ENDIF 434 438 IF( idvar > jpmax_vars ) CALL ctl_stop( TRIM(clinfo), 'increase the value of jpmax_vars' ) 435 439 IF( .NOT. PRESENT(pv_r1d) ) THEN
Note: See TracChangeset
for help on using the changeset viewer.
