| 1 |
MODULE histwrite_m |
| 2 |
|
| 3 |
! From histcom.f90, version 2.1 2004/04/21 09:27:10 |
| 4 |
|
| 5 |
implicit none |
| 6 |
|
| 7 |
PRIVATE |
| 8 |
PUBLIC histwrite |
| 9 |
|
| 10 |
INTERFACE histwrite |
| 11 |
! The "histwrite" procedures give the data to the input-output system. |
| 12 |
! They trigger the operations to be performed and the writing to |
| 13 |
! the file if needed. |
| 14 |
|
| 15 |
! We test the work to be done at this time here so that at a |
| 16 |
! later stage we can call different operations and write subroutines |
| 17 |
! for the REAL and INTEGER interfaces. |
| 18 |
|
| 19 |
! INTEGER, INTENT(IN):: pfileid |
| 20 |
! The ID of the file on which this variable is to be written. |
| 21 |
! The variable should have been defined in this file before. |
| 22 |
|
| 23 |
! CHARACTER(LEN=*), INTENT(IN):: pvarname |
| 24 |
! short name of the variable |
| 25 |
|
| 26 |
! INTEGER, INTENT(IN):: pitau |
| 27 |
! current timestep |
| 28 |
|
| 29 |
! REAL, INTENT(IN):: pdata(:) or (:, :) or (:, :, :) |
| 30 |
! values of the variable |
| 31 |
|
| 32 |
! INTEGER, INTENT(IN):: nbindex |
| 33 |
! number of indices provided |
| 34 |
! If it is equal to the size of the full field as provided in histdef |
| 35 |
! then nothing is done. |
| 36 |
|
| 37 |
! INTEGER, INTENT(IN):: nindex(nbindex) |
| 38 |
! The indices used to expand the variable (pdata) onto the full field |
| 39 |
|
| 40 |
! The difference between the procedures is the rank of "pdata". |
| 41 |
|
| 42 |
MODULE PROCEDURE histwrite_r1d, histwrite_r2d, histwrite_r3d |
| 43 |
END INTERFACE |
| 44 |
|
| 45 |
CONTAINS |
| 46 |
|
| 47 |
SUBROUTINE histwrite_r1d(pfileid, pvarname, pitau, pdata) |
| 48 |
|
| 49 |
USE errioipsl, ONLY : histerr |
| 50 |
use calendar, only: isittime |
| 51 |
USE mathelp, ONLY : mathop |
| 52 |
use histcom_var |
| 53 |
|
| 54 |
INTEGER, INTENT(IN) :: pfileid, pitau |
| 55 |
REAL, INTENT(IN) :: pdata(:) |
| 56 |
CHARACTER(LEN=*), INTENT(IN) :: pvarname |
| 57 |
|
| 58 |
! Variables local to the procedure: |
| 59 |
integer nbindex, nindex(size(pdata)) |
| 60 |
LOGICAL :: do_oper, do_write, largebuf |
| 61 |
INTEGER :: varid, io, nbpt_in, nbpt_out |
| 62 |
REAL, ALLOCATABLE, SAVE :: buff_tmp(:) |
| 63 |
INTEGER, SAVE :: buff_tmp_sz |
| 64 |
CHARACTER(LEN=7) :: tmp_opp |
| 65 |
|
| 66 |
!-------------------------------------------------------------------- |
| 67 |
|
| 68 |
nbindex = size(nindex) |
| 69 |
nindex = 0 |
| 70 |
|
| 71 |
! 1.0 Try to catch errors like specifying the wrong file ID. |
| 72 |
! Thanks Marine for showing us what errors users can make ! |
| 73 |
|
| 74 |
IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN |
| 75 |
CALL histerr (3, "histwrite", & |
| 76 |
& 'Illegal file ID in the histwrite of variable', pvarname, ' ') |
| 77 |
ENDIF |
| 78 |
|
| 79 |
! 1.1 Find the id of the variable to be written and the real time |
| 80 |
|
| 81 |
CALL histvar_seq (pfileid, pvarname, varid) |
| 82 |
|
| 83 |
! 2.0 do nothing for never operation |
| 84 |
|
| 85 |
tmp_opp = topp(pfileid, varid) |
| 86 |
|
| 87 |
IF (TRIM(tmp_opp) == "never") THEN |
| 88 |
last_opp_chk(pfileid, varid) = -99 |
| 89 |
last_wrt_chk(pfileid, varid) = -99 |
| 90 |
ENDIF |
| 91 |
|
| 92 |
! 3.0 We check if we need to do an operation |
| 93 |
|
| 94 |
IF (last_opp_chk(pfileid, varid) == pitau) THEN |
| 95 |
CALL histerr (3, "histwrite", & |
| 96 |
& 'This variable as already been analysed at the present', & |
| 97 |
& 'time step', ' ') |
| 98 |
ENDIF |
| 99 |
|
| 100 |
CALL isittime & |
| 101 |
& (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), & |
| 102 |
& last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper) |
| 103 |
|
| 104 |
! 4.0 We check if we need to write the data |
| 105 |
|
| 106 |
IF (last_wrt_chk(pfileid, varid) == pitau) THEN |
| 107 |
CALL histerr (3, "histwrite", & |
| 108 |
& 'This variable as already been written for the present', & |
| 109 |
& 'time step', ' ') |
| 110 |
ENDIF |
| 111 |
|
| 112 |
CALL isittime & |
| 113 |
& (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), & |
| 114 |
& last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write) |
| 115 |
|
| 116 |
! 5.0 histwrite called |
| 117 |
|
| 118 |
IF (do_oper.OR.do_write) THEN |
| 119 |
|
| 120 |
!- 5.1 Get the sizes of the data we will handle |
| 121 |
|
| 122 |
IF (datasz_in(pfileid, varid, 1) <= 0) THEN |
| 123 |
!--- There is the risk here that the user has over-sized the array. |
| 124 |
!--- But how can we catch this ? |
| 125 |
!--- In the worst case we will do impossible operations |
| 126 |
!--- on part of the data ! |
| 127 |
datasz_in(pfileid, varid, 1) = SIZE(pdata) |
| 128 |
datasz_in(pfileid, varid, 2) = -1 |
| 129 |
datasz_in(pfileid, varid, 3) = -1 |
| 130 |
ENDIF |
| 131 |
|
| 132 |
!- 5.2 The maximum size of the data will give the size of the buffer |
| 133 |
|
| 134 |
IF (datasz_max(pfileid, varid) <= 0) THEN |
| 135 |
largebuf = .FALSE. |
| 136 |
DO io=1, nbopp(pfileid, varid) |
| 137 |
IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN |
| 138 |
largebuf = .TRUE. |
| 139 |
ENDIF |
| 140 |
ENDDO |
| 141 |
IF (largebuf) THEN |
| 142 |
datasz_max(pfileid, varid) = & |
| 143 |
& scsize(pfileid, varid, 1) & |
| 144 |
& *scsize(pfileid, varid, 2) & |
| 145 |
& *scsize(pfileid, varid, 3) |
| 146 |
ELSE |
| 147 |
datasz_max(pfileid, varid) = & |
| 148 |
& datasz_in(pfileid, varid, 1) |
| 149 |
ENDIF |
| 150 |
ENDIF |
| 151 |
|
| 152 |
IF (.NOT.ALLOCATED(buff_tmp)) THEN |
| 153 |
ALLOCATE (buff_tmp(datasz_max(pfileid, varid))) |
| 154 |
buff_tmp_sz = datasz_max(pfileid, varid) |
| 155 |
ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN |
| 156 |
DEALLOCATE (buff_tmp) |
| 157 |
ALLOCATE (buff_tmp(datasz_max(pfileid, varid))) |
| 158 |
buff_tmp_sz = datasz_max(pfileid, varid) |
| 159 |
ENDIF |
| 160 |
|
| 161 |
!- We have to do the first operation anyway. |
| 162 |
!- Thus we do it here and change the ranke |
| 163 |
!- of the data at the same time. This should speed up things. |
| 164 |
|
| 165 |
nbpt_in = datasz_in(pfileid, varid, 1) |
| 166 |
nbpt_out = datasz_max(pfileid, varid) |
| 167 |
CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, & |
| 168 |
& missing_val, nbindex, nindex, & |
| 169 |
& scal(pfileid, varid, 1), nbpt_out, buff_tmp) |
| 170 |
CALL histwrite_real (pfileid, varid, pitau, nbpt_out, & |
| 171 |
& buff_tmp, nbindex, nindex, do_oper, do_write) |
| 172 |
ENDIF |
| 173 |
|
| 174 |
! 6.0 Manage time steps |
| 175 |
|
| 176 |
IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN |
| 177 |
last_opp_chk(pfileid, varid) = pitau |
| 178 |
last_wrt_chk(pfileid, varid) = pitau |
| 179 |
ELSE |
| 180 |
last_opp_chk(pfileid, varid) = -99 |
| 181 |
last_wrt_chk(pfileid, varid) = -99 |
| 182 |
ENDIF |
| 183 |
!-------------------------- |
| 184 |
END SUBROUTINE histwrite_r1d |
| 185 |
|
| 186 |
!=== |
| 187 |
|
| 188 |
SUBROUTINE histwrite_r2d (pfileid, pvarname, pitau, pdata) |
| 189 |
!-------------------------------------------------------------------- |
| 190 |
|
| 191 |
use calendar, only: isittime |
| 192 |
USE errioipsl, ONLY : histerr |
| 193 |
USE mathelp, ONLY : mathop |
| 194 |
use histcom_var |
| 195 |
|
| 196 |
INTEGER, INTENT(IN) :: pfileid, pitau |
| 197 |
REAL, DIMENSION(:, :), INTENT(IN) :: pdata |
| 198 |
CHARACTER(LEN=*), INTENT(IN) :: pvarname |
| 199 |
|
| 200 |
integer nbindex, nindex(size(pdata)) |
| 201 |
LOGICAL :: do_oper, do_write, largebuf |
| 202 |
INTEGER :: varid, io, nbpt_in(1:2), nbpt_out |
| 203 |
REAL, ALLOCATABLE, SAVE :: buff_tmp(:) |
| 204 |
INTEGER, SAVE :: buff_tmp_sz |
| 205 |
CHARACTER(LEN=7) :: tmp_opp |
| 206 |
|
| 207 |
!-------------------------------------------------------------------- |
| 208 |
|
| 209 |
nbindex = size(nindex) |
| 210 |
nindex = 0 |
| 211 |
|
| 212 |
! 1.0 Try to catch errors like specifying the wrong file ID. |
| 213 |
! Thanks Marine for showing us what errors users can make ! |
| 214 |
|
| 215 |
IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN |
| 216 |
CALL histerr (3, "histwrite", & |
| 217 |
& 'Illegal file ID in the histwrite of variable', pvarname, ' ') |
| 218 |
ENDIF |
| 219 |
|
| 220 |
! 1.1 Find the id of the variable to be written and the real time |
| 221 |
|
| 222 |
CALL histvar_seq (pfileid, pvarname, varid) |
| 223 |
|
| 224 |
! 2.0 do nothing for never operation |
| 225 |
|
| 226 |
tmp_opp = topp(pfileid, varid) |
| 227 |
|
| 228 |
IF (TRIM(tmp_opp) == "never") THEN |
| 229 |
last_opp_chk(pfileid, varid) = -99 |
| 230 |
last_wrt_chk(pfileid, varid) = -99 |
| 231 |
ENDIF |
| 232 |
|
| 233 |
! 3.0 We check if we need to do an operation |
| 234 |
|
| 235 |
IF (last_opp_chk(pfileid, varid) == pitau) THEN |
| 236 |
CALL histerr (3, "histwrite", & |
| 237 |
& 'This variable as already been analysed at the present', & |
| 238 |
& 'time step', ' ') |
| 239 |
ENDIF |
| 240 |
|
| 241 |
CALL isittime & |
| 242 |
& (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), & |
| 243 |
& last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper) |
| 244 |
|
| 245 |
! 4.0 We check if we need to write the data |
| 246 |
|
| 247 |
IF (last_wrt_chk(pfileid, varid) == pitau) THEN |
| 248 |
CALL histerr (3, "histwrite", & |
| 249 |
& 'This variable as already been written for the present', & |
| 250 |
& 'time step', ' ') |
| 251 |
ENDIF |
| 252 |
|
| 253 |
CALL isittime & |
| 254 |
& (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), & |
| 255 |
& last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write) |
| 256 |
|
| 257 |
! 5.0 histwrite called |
| 258 |
|
| 259 |
IF (do_oper.OR.do_write) THEN |
| 260 |
|
| 261 |
!- 5.1 Get the sizes of the data we will handle |
| 262 |
|
| 263 |
IF (datasz_in(pfileid, varid, 1) <= 0) THEN |
| 264 |
!--- There is the risk here that the user has over-sized the array. |
| 265 |
!--- But how can we catch this ? |
| 266 |
!--- In the worst case we will do impossible operations |
| 267 |
!--- on part of the data ! |
| 268 |
datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1) |
| 269 |
datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2) |
| 270 |
datasz_in(pfileid, varid, 3) = -1 |
| 271 |
ENDIF |
| 272 |
|
| 273 |
!- 5.2 The maximum size of the data will give the size of the buffer |
| 274 |
|
| 275 |
IF (datasz_max(pfileid, varid) <= 0) THEN |
| 276 |
largebuf = .FALSE. |
| 277 |
DO io=1, nbopp(pfileid, varid) |
| 278 |
IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN |
| 279 |
largebuf = .TRUE. |
| 280 |
ENDIF |
| 281 |
ENDDO |
| 282 |
IF (largebuf) THEN |
| 283 |
datasz_max(pfileid, varid) = & |
| 284 |
& scsize(pfileid, varid, 1) & |
| 285 |
& *scsize(pfileid, varid, 2) & |
| 286 |
& *scsize(pfileid, varid, 3) |
| 287 |
ELSE |
| 288 |
datasz_max(pfileid, varid) = & |
| 289 |
& datasz_in(pfileid, varid, 1) & |
| 290 |
& *datasz_in(pfileid, varid, 2) |
| 291 |
ENDIF |
| 292 |
ENDIF |
| 293 |
|
| 294 |
IF (.NOT.ALLOCATED(buff_tmp)) THEN |
| 295 |
ALLOCATE (buff_tmp(datasz_max(pfileid, varid))) |
| 296 |
buff_tmp_sz = datasz_max(pfileid, varid) |
| 297 |
ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN |
| 298 |
DEALLOCATE (buff_tmp) |
| 299 |
ALLOCATE (buff_tmp(datasz_max(pfileid, varid))) |
| 300 |
buff_tmp_sz = datasz_max(pfileid, varid) |
| 301 |
ENDIF |
| 302 |
|
| 303 |
!- We have to do the first operation anyway. |
| 304 |
!- Thus we do it here and change the ranke |
| 305 |
!- of the data at the same time. This should speed up things. |
| 306 |
|
| 307 |
nbpt_in(1:2) = datasz_in(pfileid, varid, 1:2) |
| 308 |
nbpt_out = datasz_max(pfileid, varid) |
| 309 |
CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, & |
| 310 |
& missing_val, nbindex, nindex, & |
| 311 |
& scal(pfileid, varid, 1), nbpt_out, buff_tmp) |
| 312 |
CALL histwrite_real (pfileid, varid, pitau, nbpt_out, & |
| 313 |
& buff_tmp, nbindex, nindex, do_oper, do_write) |
| 314 |
ENDIF |
| 315 |
|
| 316 |
! 6.0 Manage time steps |
| 317 |
|
| 318 |
IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN |
| 319 |
last_opp_chk(pfileid, varid) = pitau |
| 320 |
last_wrt_chk(pfileid, varid) = pitau |
| 321 |
ELSE |
| 322 |
last_opp_chk(pfileid, varid) = -99 |
| 323 |
last_wrt_chk(pfileid, varid) = -99 |
| 324 |
ENDIF |
| 325 |
!-------------------------- |
| 326 |
END SUBROUTINE histwrite_r2d |
| 327 |
|
| 328 |
!=== |
| 329 |
|
| 330 |
SUBROUTINE histwrite_r3d (pfileid, pvarname, pitau, pdata) |
| 331 |
!-------------------------------------------------------------------- |
| 332 |
|
| 333 |
use calendar, only: isittime |
| 334 |
USE errioipsl, ONLY : histerr |
| 335 |
USE mathelp, ONLY : mathop |
| 336 |
use histcom_var |
| 337 |
|
| 338 |
INTEGER, INTENT(IN) :: pfileid, pitau |
| 339 |
REAL, DIMENSION(:, :, :), INTENT(IN) :: pdata |
| 340 |
CHARACTER(LEN=*), INTENT(IN) :: pvarname |
| 341 |
|
| 342 |
integer nbindex, nindex(size(pdata)) |
| 343 |
LOGICAL :: do_oper, do_write, largebuf |
| 344 |
INTEGER :: varid, io, nbpt_in(1:3), nbpt_out |
| 345 |
REAL, ALLOCATABLE, SAVE :: buff_tmp(:) |
| 346 |
INTEGER, SAVE :: buff_tmp_sz |
| 347 |
CHARACTER(LEN=7) :: tmp_opp |
| 348 |
|
| 349 |
!-------------------------------------------------------------------- |
| 350 |
|
| 351 |
nbindex = size(nindex) |
| 352 |
nindex = 0 |
| 353 |
|
| 354 |
! 1.0 Try to catch errors like specifying the wrong file ID. |
| 355 |
! Thanks Marine for showing us what errors users can make ! |
| 356 |
|
| 357 |
IF ( (pfileid < 1).OR.(pfileid > nb_files) ) THEN |
| 358 |
CALL histerr (3, "histwrite", & |
| 359 |
& 'Illegal file ID in the histwrite of variable', pvarname, ' ') |
| 360 |
ENDIF |
| 361 |
|
| 362 |
! 1.1 Find the id of the variable to be written and the real time |
| 363 |
|
| 364 |
CALL histvar_seq (pfileid, pvarname, varid) |
| 365 |
|
| 366 |
! 2.0 do nothing for never operation |
| 367 |
|
| 368 |
tmp_opp = topp(pfileid, varid) |
| 369 |
|
| 370 |
IF (TRIM(tmp_opp) == "never") THEN |
| 371 |
last_opp_chk(pfileid, varid) = -99 |
| 372 |
last_wrt_chk(pfileid, varid) = -99 |
| 373 |
ENDIF |
| 374 |
|
| 375 |
! 3.0 We check if we need to do an operation |
| 376 |
|
| 377 |
IF (last_opp_chk(pfileid, varid) == pitau) THEN |
| 378 |
CALL histerr (3, "histwrite", & |
| 379 |
& 'This variable as already been analysed at the present', & |
| 380 |
& 'time step', ' ') |
| 381 |
ENDIF |
| 382 |
|
| 383 |
CALL isittime & |
| 384 |
& (pitau, date0(pfileid), deltat(pfileid), freq_opp(pfileid, varid), & |
| 385 |
& last_opp(pfileid, varid), last_opp_chk(pfileid, varid), do_oper) |
| 386 |
|
| 387 |
! 4.0 We check if we need to write the data |
| 388 |
|
| 389 |
IF (last_wrt_chk(pfileid, varid) == pitau) THEN |
| 390 |
CALL histerr (3, "histwrite", & |
| 391 |
& 'This variable as already been written for the present', & |
| 392 |
& 'time step', ' ') |
| 393 |
ENDIF |
| 394 |
|
| 395 |
CALL isittime & |
| 396 |
& (pitau, date0(pfileid), deltat(pfileid), freq_wrt(pfileid, varid), & |
| 397 |
& last_wrt(pfileid, varid), last_wrt_chk(pfileid, varid), do_write) |
| 398 |
|
| 399 |
! 5.0 histwrite called |
| 400 |
|
| 401 |
IF (do_oper.OR.do_write) THEN |
| 402 |
|
| 403 |
!- 5.1 Get the sizes of the data we will handle |
| 404 |
|
| 405 |
IF (datasz_in(pfileid, varid, 1) <= 0) THEN |
| 406 |
!--- There is the risk here that the user has over-sized the array. |
| 407 |
!--- But how can we catch this ? |
| 408 |
!--- In the worst case we will do impossible operations |
| 409 |
!--- on part of the data ! |
| 410 |
datasz_in(pfileid, varid, 1) = SIZE(pdata, DIM=1) |
| 411 |
datasz_in(pfileid, varid, 2) = SIZE(pdata, DIM=2) |
| 412 |
datasz_in(pfileid, varid, 3) = SIZE(pdata, DIM=3) |
| 413 |
ENDIF |
| 414 |
|
| 415 |
!- 5.2 The maximum size of the data will give the size of the buffer |
| 416 |
|
| 417 |
IF (datasz_max(pfileid, varid) <= 0) THEN |
| 418 |
largebuf = .FALSE. |
| 419 |
DO io =1, nbopp(pfileid, varid) |
| 420 |
IF (INDEX(fuchnbout, sopps(pfileid, varid, io)) > 0) THEN |
| 421 |
largebuf = .TRUE. |
| 422 |
ENDIF |
| 423 |
ENDDO |
| 424 |
IF (largebuf) THEN |
| 425 |
datasz_max(pfileid, varid) = & |
| 426 |
& scsize(pfileid, varid, 1) & |
| 427 |
& *scsize(pfileid, varid, 2) & |
| 428 |
& *scsize(pfileid, varid, 3) |
| 429 |
ELSE |
| 430 |
datasz_max(pfileid, varid) = & |
| 431 |
& datasz_in(pfileid, varid, 1) & |
| 432 |
& *datasz_in(pfileid, varid, 2) & |
| 433 |
& *datasz_in(pfileid, varid, 3) |
| 434 |
ENDIF |
| 435 |
ENDIF |
| 436 |
|
| 437 |
IF (.NOT.ALLOCATED(buff_tmp)) THEN |
| 438 |
ALLOCATE (buff_tmp(datasz_max(pfileid, varid))) |
| 439 |
buff_tmp_sz = datasz_max(pfileid, varid) |
| 440 |
ELSE IF (datasz_max(pfileid, varid) > buff_tmp_sz) THEN |
| 441 |
DEALLOCATE (buff_tmp) |
| 442 |
ALLOCATE (buff_tmp(datasz_max(pfileid, varid))) |
| 443 |
buff_tmp_sz = datasz_max(pfileid, varid) |
| 444 |
ENDIF |
| 445 |
|
| 446 |
!- We have to do the first operation anyway. |
| 447 |
!- Thus we do it here and change the ranke |
| 448 |
!- of the data at the same time. This should speed up things. |
| 449 |
|
| 450 |
nbpt_in(1:3) = datasz_in(pfileid, varid, 1:3) |
| 451 |
nbpt_out = datasz_max(pfileid, varid) |
| 452 |
CALL mathop (sopps(pfileid, varid, 1), nbpt_in, pdata, & |
| 453 |
& missing_val, nbindex, nindex, & |
| 454 |
& scal(pfileid, varid, 1), nbpt_out, buff_tmp) |
| 455 |
CALL histwrite_real (pfileid, varid, pitau, nbpt_out, & |
| 456 |
& buff_tmp, nbindex, nindex, do_oper, do_write) |
| 457 |
ENDIF |
| 458 |
|
| 459 |
! 6.0 Manage time steps |
| 460 |
|
| 461 |
IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN |
| 462 |
last_opp_chk(pfileid, varid) = pitau |
| 463 |
last_wrt_chk(pfileid, varid) = pitau |
| 464 |
ELSE |
| 465 |
last_opp_chk(pfileid, varid) = -99 |
| 466 |
last_wrt_chk(pfileid, varid) = -99 |
| 467 |
ENDIF |
| 468 |
!-------------------------- |
| 469 |
END SUBROUTINE histwrite_r3d |
| 470 |
|
| 471 |
!=== |
| 472 |
|
| 473 |
SUBROUTINE histwrite_real(pfileid, varid, pitau, nbdpt, buff_tmp, nbindex, & |
| 474 |
nindex, do_oper, do_write) |
| 475 |
|
| 476 |
! This subroutine is internal and does the calculations and writing |
| 477 |
! if needed. At a later stage it should be split into an operation |
| 478 |
! and writing subroutines. |
| 479 |
!-------------------------------------------------------------------- |
| 480 |
|
| 481 |
USE mathelp, ONLY : mathop, trans_buff, moycum |
| 482 |
use netcdf, only: NF90_PUT_VAR |
| 483 |
use histcom_var |
| 484 |
|
| 485 |
INTEGER, INTENT(IN) :: pfileid, pitau, varid, & |
| 486 |
& nbindex, nindex(nbindex), nbdpt |
| 487 |
REAL, DIMENSION(:) :: buff_tmp |
| 488 |
LOGICAL, INTENT(IN) :: do_oper, do_write |
| 489 |
|
| 490 |
INTEGER :: tsz, ncid, ncvarid |
| 491 |
INTEGER :: i, iret, ipt, itax |
| 492 |
INTEGER :: io, nbin, nbout |
| 493 |
INTEGER, DIMENSION(4) :: corner, edges |
| 494 |
INTEGER :: itime |
| 495 |
|
| 496 |
REAL :: rtime |
| 497 |
CHARACTER(LEN=7) :: tmp_opp |
| 498 |
|
| 499 |
REAL, ALLOCATABLE, SAVE :: buff_tmp2(:) |
| 500 |
INTEGER, SAVE :: buff_tmp2_sz |
| 501 |
REAL, ALLOCATABLE, SAVE :: buffer_used(:) |
| 502 |
INTEGER, SAVE :: buffer_sz |
| 503 |
|
| 504 |
!-------------------------------------------------------------------- |
| 505 |
|
| 506 |
! The sizes which can be encoutered |
| 507 |
|
| 508 |
tsz = zsize(pfileid, varid, 1)*zsize(pfileid, varid, 2)*zsize(pfileid, varid, 3) |
| 509 |
|
| 510 |
! 1.0 We allocate the memory needed to store the data between write |
| 511 |
! and the temporary space needed for operations. |
| 512 |
! We have to keep precedent buffer if needed |
| 513 |
|
| 514 |
IF (.NOT. ALLOCATED(buffer)) THEN |
| 515 |
ALLOCATE(buffer(buff_pos)) |
| 516 |
buffer_sz = buff_pos |
| 517 |
buffer(:)=0.0 |
| 518 |
ELSE IF (buffer_sz < buff_pos) THEN |
| 519 |
IF (SUM(buffer)/=0.0) THEN |
| 520 |
ALLOCATE (buffer_used(buffer_sz)) |
| 521 |
buffer_used(:)=buffer(:) |
| 522 |
DEALLOCATE (buffer) |
| 523 |
ALLOCATE (buffer(buff_pos)) |
| 524 |
buffer_sz = buff_pos |
| 525 |
buffer(:SIZE(buffer_used))=buffer_used |
| 526 |
DEALLOCATE (buffer_used) |
| 527 |
ELSE |
| 528 |
DEALLOCATE (buffer) |
| 529 |
ALLOCATE (buffer(buff_pos)) |
| 530 |
buffer_sz = buff_pos |
| 531 |
buffer(:)=0.0 |
| 532 |
ENDIF |
| 533 |
ENDIF |
| 534 |
|
| 535 |
! The buffers are only deallocated when more space is needed. This |
| 536 |
! reduces the umber of allocates but increases memory needs. |
| 537 |
|
| 538 |
IF (.NOT.ALLOCATED(buff_tmp2)) THEN |
| 539 |
ALLOCATE (buff_tmp2(datasz_max(pfileid, varid))) |
| 540 |
buff_tmp2_sz = datasz_max(pfileid, varid) |
| 541 |
ELSE IF ( datasz_max(pfileid, varid) > buff_tmp2_sz) THEN |
| 542 |
DEALLOCATE (buff_tmp2) |
| 543 |
ALLOCATE (buff_tmp2(datasz_max(pfileid, varid))) |
| 544 |
buff_tmp2_sz = datasz_max(pfileid, varid) |
| 545 |
ENDIF |
| 546 |
|
| 547 |
rtime = pitau * deltat(pfileid) |
| 548 |
tmp_opp = topp(pfileid, varid) |
| 549 |
|
| 550 |
! 3.0 Do the operations or transfer the slab of data into buff_tmp |
| 551 |
|
| 552 |
! 3.1 DO the Operations only if needed |
| 553 |
|
| 554 |
IF ( do_oper ) THEN |
| 555 |
i = pfileid |
| 556 |
nbout = nbdpt |
| 557 |
|
| 558 |
!- 3.4 We continue the sequence of operations |
| 559 |
!- we started in the interface routine |
| 560 |
|
| 561 |
DO io = 2, nbopp(i, varid), 2 |
| 562 |
nbin = nbout |
| 563 |
nbout = datasz_max(i, varid) |
| 564 |
CALL mathop(sopps(i, varid, io), nbin, buff_tmp, missing_val, & |
| 565 |
& nbindex, nindex, scal(i, varid, io), nbout, buff_tmp2) |
| 566 |
|
| 567 |
nbin = nbout |
| 568 |
nbout = datasz_max(i, varid) |
| 569 |
CALL mathop(sopps(i, varid, io+1), nbin, buff_tmp2, missing_val, & |
| 570 |
& nbindex, nindex, scal(i, varid, io+1), nbout, buff_tmp) |
| 571 |
ENDDO |
| 572 |
|
| 573 |
! 3.5 Zoom into the data |
| 574 |
|
| 575 |
CALL trans_buff & |
| 576 |
& (zorig(i, varid, 1), zsize(i, varid, 1), & |
| 577 |
& zorig(i, varid, 2), zsize(i, varid, 2), & |
| 578 |
& zorig(i, varid, 3), zsize(i, varid, 3), & |
| 579 |
& scsize(i, varid, 1), scsize(i, varid, 2), scsize(i, varid, 3), & |
| 580 |
& buff_tmp, buff_tmp2_sz, buff_tmp2) |
| 581 |
|
| 582 |
!- 5.0 Do the operations if needed. In the case of instantaneous |
| 583 |
!- output we do not transfer to the buffer. |
| 584 |
|
| 585 |
ipt = point(pfileid, varid) |
| 586 |
|
| 587 |
IF ( (TRIM(tmp_opp) /= "inst") & |
| 588 |
& .AND.(TRIM(tmp_opp) /= "once") ) THEN |
| 589 |
CALL moycum(tmp_opp, tsz, buffer(ipt:), & |
| 590 |
& buff_tmp2, nb_opp(pfileid, varid)) |
| 591 |
ENDIF |
| 592 |
|
| 593 |
last_opp(pfileid, varid) = pitau |
| 594 |
nb_opp(pfileid, varid) = nb_opp(pfileid, varid)+1 |
| 595 |
|
| 596 |
ENDIF |
| 597 |
|
| 598 |
! 6.0 Write to file if needed |
| 599 |
|
| 600 |
IF ( do_write ) THEN |
| 601 |
|
| 602 |
ncvarid = ncvar_ids(pfileid, varid) |
| 603 |
ncid = ncdf_ids(pfileid) |
| 604 |
|
| 605 |
!- 6.1 Do the operations that are needed before writting |
| 606 |
|
| 607 |
IF ( (TRIM(tmp_opp) /= "inst") & |
| 608 |
& .AND.(TRIM(tmp_opp) /= "once") ) THEN |
| 609 |
rtime = (rtime+last_wrt(pfileid, varid)*deltat(pfileid))/2.0 |
| 610 |
ENDIF |
| 611 |
|
| 612 |
!- 6.2 Add a value to the time axis of this variable if needed |
| 613 |
|
| 614 |
IF ( (TRIM(tmp_opp) /= "l_max") & |
| 615 |
& .AND.(TRIM(tmp_opp) /= "l_min") & |
| 616 |
& .AND.(TRIM(tmp_opp) /= "once") ) THEN |
| 617 |
|
| 618 |
itax = var_axid(pfileid, varid) |
| 619 |
itime = nb_wrt(pfileid, varid)+1 |
| 620 |
|
| 621 |
IF (tax_last(pfileid, itax) < itime) THEN |
| 622 |
iret = NF90_PUT_VAR (ncid, tdimid(pfileid, itax), (/ rtime /), & |
| 623 |
& start=(/ itime /), count=(/ 1 /)) |
| 624 |
tax_last(pfileid, itax) = itime |
| 625 |
ENDIF |
| 626 |
ELSE |
| 627 |
itime=1 |
| 628 |
ENDIF |
| 629 |
|
| 630 |
!- 6.3 Write the data. Only in the case of instantaneous output |
| 631 |
! we do not write the buffer. |
| 632 |
|
| 633 |
IF (scsize(pfileid, varid, 3) == 1) THEN |
| 634 |
IF (regular(pfileid)) THEN |
| 635 |
corner(1:4) = (/ 1, 1, itime, 0 /) |
| 636 |
edges(1:4) = (/ zsize(pfileid, varid, 1), & |
| 637 |
& zsize(pfileid, varid, 2), & |
| 638 |
& 1, 0 /) |
| 639 |
ELSE |
| 640 |
corner(1:4) = (/ 1, itime, 0, 0 /) |
| 641 |
edges(1:4) = (/ zsize(pfileid, varid, 1), 1, 0, 0 /) |
| 642 |
ENDIF |
| 643 |
ELSE |
| 644 |
IF ( regular(pfileid) ) THEN |
| 645 |
corner(1:4) = (/ 1, 1, 1, itime /) |
| 646 |
edges(1:4) = (/ zsize(pfileid, varid, 1), & |
| 647 |
& zsize(pfileid, varid, 2), & |
| 648 |
& zsize(pfileid, varid, 3), 1 /) |
| 649 |
ELSE |
| 650 |
corner(1:4) = (/ 1, 1, itime, 0 /) |
| 651 |
edges(1:4) = (/ zsize(pfileid, varid, 1), & |
| 652 |
& zsize(pfileid, varid, 3), 1, 0 /) |
| 653 |
ENDIF |
| 654 |
ENDIF |
| 655 |
|
| 656 |
ipt = point(pfileid, varid) |
| 657 |
|
| 658 |
IF ( (TRIM(tmp_opp) /= "inst") & |
| 659 |
& .AND.(TRIM(tmp_opp) /= "once") ) THEN |
| 660 |
iret = NF90_PUT_VAR (ncid, ncvarid, buffer(ipt:), & |
| 661 |
& start=corner(1:4), count=edges(1:4)) |
| 662 |
ELSE |
| 663 |
iret = NF90_PUT_VAR (ncid, ncvarid, buff_tmp2, & |
| 664 |
& start=corner(1:4), count=edges(1:4)) |
| 665 |
ENDIF |
| 666 |
|
| 667 |
last_wrt(pfileid, varid) = pitau |
| 668 |
nb_wrt(pfileid, varid) = nb_wrt(pfileid, varid)+1 |
| 669 |
nb_opp(pfileid, varid) = 0 |
| 670 |
!-- |
| 671 |
! After the write the file can be synchronized so that no data is |
| 672 |
! lost in case of a crash. This feature gives up on the benefits of |
| 673 |
! buffering and should only be used in debuging mode. A flag is |
| 674 |
! needed here to switch to this mode. |
| 675 |
!-- |
| 676 |
! iret = NF90_SYNC (ncid) |
| 677 |
|
| 678 |
ENDIF |
| 679 |
!--------------------------- |
| 680 |
END SUBROUTINE histwrite_real |
| 681 |
|
| 682 |
!************************************************************* |
| 683 |
|
| 684 |
SUBROUTINE histvar_seq (pfid, pvarname, pvid) |
| 685 |
|
| 686 |
! This subroutine optimized the search for the variable in the table. |
| 687 |
! In a first phase it will learn the succession of the variables |
| 688 |
! called and then it will use the table to guess what comes next. |
| 689 |
! It is the best solution to avoid lengthy searches through array |
| 690 |
! vectors. |
| 691 |
|
| 692 |
! ARGUMENTS : |
| 693 |
|
| 694 |
! pfid : id of the file on which we work |
| 695 |
! pvarname : The name of the variable we are looking for |
| 696 |
! pvid : The var id we found |
| 697 |
|
| 698 |
USE stringop, ONLY: find_str |
| 699 |
USE errioipsl, ONLY : histerr |
| 700 |
use histcom_var |
| 701 |
|
| 702 |
INTEGER, INTENT(in) :: pfid |
| 703 |
CHARACTER(LEN=*), INTENT(IN) :: pvarname |
| 704 |
INTEGER, INTENT(out) :: pvid |
| 705 |
|
| 706 |
LOGICAL, SAVE :: learning(nb_files_max)=.TRUE. |
| 707 |
INTEGER, SAVE :: overlap(nb_files_max) = -1 |
| 708 |
INTEGER, SAVE :: varseq(nb_files_max, nb_var_max*3) |
| 709 |
INTEGER, SAVE :: varseq_len(nb_files_max) = 0 |
| 710 |
INTEGER, SAVE :: varseq_pos(nb_files_max) |
| 711 |
INTEGER, SAVE :: varseq_err(nb_files_max) = 0 |
| 712 |
INTEGER :: nb, sp, nx, pos, ib |
| 713 |
CHARACTER(LEN=20), DIMENSION(nb_var_max) :: tab_str20 |
| 714 |
CHARACTER(LEN=20) :: str20 |
| 715 |
CHARACTER(LEN=70) :: str70 |
| 716 |
INTEGER :: tab_str20_length(nb_var_max) |
| 717 |
|
| 718 |
!-------------------------------------------------------------------- |
| 719 |
nb = nb_var(pfid) |
| 720 |
|
| 721 |
IF (learning(pfid)) THEN |
| 722 |
|
| 723 |
!- 1.0 We compute the length over which we are going |
| 724 |
!- to check the overlap |
| 725 |
|
| 726 |
IF (overlap(pfid) <= 0) THEN |
| 727 |
IF (nb_var(pfid) > 6) THEN |
| 728 |
overlap(pfid) = nb_var(pfid)/3*2 |
| 729 |
ELSE |
| 730 |
overlap(pfid) = nb_var(pfid) |
| 731 |
ENDIF |
| 732 |
ENDIF |
| 733 |
|
| 734 |
!- 1.1 Find the position of this string |
| 735 |
|
| 736 |
str20 = pvarname |
| 737 |
tab_str20(1:nb) = name(pfid, 1:nb) |
| 738 |
tab_str20_length(1:nb) = name_length(pfid, 1:nb) |
| 739 |
|
| 740 |
CALL find_str (nb, tab_str20, tab_str20_length, str20, pos) |
| 741 |
|
| 742 |
IF (pos > 0) THEN |
| 743 |
pvid = pos |
| 744 |
ELSE |
| 745 |
CALL histerr (3, "histvar_seq", & |
| 746 |
& 'The name of the variable you gave has not been declared', & |
| 747 |
& 'You should use subroutine histdef for declaring variable', & |
| 748 |
& TRIM(str20)) |
| 749 |
ENDIF |
| 750 |
|
| 751 |
!- 1.2 If we have not given up we store the position |
| 752 |
!- in the sequence of calls |
| 753 |
|
| 754 |
IF ( varseq_err(pfid) .GE. 0 ) THEN |
| 755 |
sp = varseq_len(pfid)+1 |
| 756 |
IF (sp <= nb_var_max*3) THEN |
| 757 |
varseq(pfid, sp) = pvid |
| 758 |
varseq_len(pfid) = sp |
| 759 |
ELSE |
| 760 |
CALL histerr (2, "histvar_seq", & |
| 761 |
& 'The learning process has failed and we give up. '// & |
| 762 |
& 'Either you sequence is', & |
| 763 |
& 'too complex or I am too dumb. '// & |
| 764 |
& 'This will only affect the efficiency', & |
| 765 |
& 'of your code. Thus if you wish to save time'// & |
| 766 |
& ' contact the IOIPSL team. ') |
| 767 |
WRITE(*, *) 'The sequence we have found up to now :' |
| 768 |
WRITE(*, *) varseq(pfid, 1:sp-1) |
| 769 |
varseq_err(pfid) = -1 |
| 770 |
ENDIF |
| 771 |
|
| 772 |
!--- 1.3 Check if we have found the right overlap |
| 773 |
|
| 774 |
IF (varseq_len(pfid) .GE. overlap(pfid)*2) THEN |
| 775 |
|
| 776 |
!----- We skip a few variables if needed as they could come |
| 777 |
!----- from the initialisation of the model. |
| 778 |
|
| 779 |
DO ib = 0, sp-overlap(pfid)*2 |
| 780 |
IF ( learning(pfid) .AND.& |
| 781 |
& SUM(ABS(varseq(pfid, ib+1:ib+overlap(pfid)) -& |
| 782 |
& varseq(pfid, sp-overlap(pfid)+1:sp))) == 0 ) THEN |
| 783 |
learning(pfid) = .FALSE. |
| 784 |
varseq_len(pfid) = sp-overlap(pfid)-ib |
| 785 |
varseq_pos(pfid) = overlap(pfid)+ib |
| 786 |
varseq(pfid, 1:varseq_len(pfid)) = & |
| 787 |
& varseq(pfid, ib+1:ib+varseq_len(pfid)) |
| 788 |
ENDIF |
| 789 |
ENDDO |
| 790 |
ENDIF |
| 791 |
ENDIF |
| 792 |
ELSE |
| 793 |
|
| 794 |
!- 2.0 Now we know how the calls to histwrite are sequenced |
| 795 |
!- and we can get a guess at the var ID |
| 796 |
|
| 797 |
nx = varseq_pos(pfid)+1 |
| 798 |
IF (nx > varseq_len(pfid)) nx = 1 |
| 799 |
|
| 800 |
pvid = varseq(pfid, nx) |
| 801 |
|
| 802 |
IF ( (INDEX(name(pfid, pvid), pvarname) <= 0) & |
| 803 |
& .OR.(name_length(pfid, pvid) /= len_trim(pvarname)) ) THEN |
| 804 |
str20 = pvarname |
| 805 |
tab_str20(1:nb) = name(pfid, 1:nb) |
| 806 |
tab_str20_length(1:nb) = name_length(pfid, 1:nb) |
| 807 |
CALL find_str (nb, tab_str20, tab_str20_length, str20, pos) |
| 808 |
IF (pos > 0) THEN |
| 809 |
pvid = pos |
| 810 |
ELSE |
| 811 |
CALL histerr(3, "histvar_seq", & |
| 812 |
& 'The name of the variable you gave has not been declared', & |
| 813 |
& 'You should use subroutine histdef for declaring variable', str20) |
| 814 |
ENDIF |
| 815 |
varseq_err(pfid) = varseq_err(pfid)+1 |
| 816 |
ELSE |
| 817 |
|
| 818 |
!--- We only keep the new position if we have found the variable |
| 819 |
!--- this way. This way an out of sequence call to histwrite does |
| 820 |
!--- not defeat the process. |
| 821 |
|
| 822 |
varseq_pos(pfid) = nx |
| 823 |
ENDIF |
| 824 |
|
| 825 |
IF (varseq_err(pfid) .GE. 10) THEN |
| 826 |
WRITE(str70, '("for file ", I3)') pfid |
| 827 |
CALL histerr(2, "histvar_seq", & |
| 828 |
& 'There were 10 errors in the learned sequence of variables', & |
| 829 |
& str70, 'This looks like a bug, please report it.') |
| 830 |
varseq_err(pfid) = 0 |
| 831 |
ENDIF |
| 832 |
ENDIF |
| 833 |
|
| 834 |
END SUBROUTINE histvar_seq |
| 835 |
|
| 836 |
END MODULE histwrite_m |
Parent Directory
| 
Revision Log