| 1 |
module histdef_m |
| 2 |
|
| 3 |
implicit none |
| 4 |
|
| 5 |
contains |
| 6 |
|
| 7 |
SUBROUTINE histdef(fileid, varname, ptitle, unit, xsize, ysize, & |
| 8 |
horiid, pzsize, oriz, szz, zid, opp, pfreq_opp, pfreq_wrt) |
| 9 |
|
| 10 |
! With this subroutine each variable to be archived on the history |
| 11 |
! tape should be declared. It gives the user the choice of |
| 12 |
! operation to be performed on the variable, the frequency of |
| 13 |
! this operation and the frequency of the archiving. |
| 14 |
|
| 15 |
USE errioipsl, ONLY: histerr |
| 16 |
USE find_str_m, ONLY: find_str |
| 17 |
USE histcom_var, ONLY: buff_pos, deltat, freq_opp, freq_wrt, fullop, & |
| 18 |
full_size, itau0, last_opp, last_opp_chk, last_wrt, last_wrt_chk, & |
| 19 |
missing_val, name, name_length, nbopp, nbopp_max, nb_hax, nb_opp, & |
| 20 |
nb_tax, nb_var, nb_var_max, nb_wrt, nb_zax, point, scal, scsize, & |
| 21 |
slab_ori, slab_sz, sopps, tax_last, tax_name, tax_name_length, & |
| 22 |
title, topp, unit_name, var_axid, var_haxid, var_zaxid, zax_name, & |
| 23 |
zax_size, zorig, zsize |
| 24 |
USE ioget_calendar_m, ONLY: ioget_calendar |
| 25 |
USE mathelp, ONLY: buildop |
| 26 |
|
| 27 |
INTEGER, INTENT(IN):: fileid |
| 28 |
! (ID of the file the variable should be archived in) |
| 29 |
|
| 30 |
CHARACTER(len=*), INTENT(IN):: varname |
| 31 |
! (name of the variable, short and easy to remember) |
| 32 |
|
| 33 |
CHARACTER(len=*), INTENT(IN):: ptitle ! full name of the variable |
| 34 |
CHARACTER(len=*), INTENT(IN):: unit ! units of the variable |
| 35 |
|
| 36 |
! The next 3 arguments give the size of that data |
| 37 |
! that will be passed to histwrite. The zoom will be |
| 38 |
! done there with the horizontal information obtained |
| 39 |
! in "histbeg" and the vertical information to follow. |
| 40 |
INTEGER, INTENT(IN):: xsize, ysize ! Sizes in X and Y directions |
| 41 |
INTEGER, INTENT(IN):: horiid ! ID of the horizontal axis |
| 42 |
|
| 43 |
! The next two arguments give the vertical zoom to use. |
| 44 |
|
| 45 |
INTEGER, INTENT(IN):: pzsize |
| 46 |
! (Size in Z direction (If 1 then no axis is declared for this |
| 47 |
! variable and zid is not used) |
| 48 |
|
| 49 |
INTEGER, INTENT(IN):: oriz ! Off set of the zoom |
| 50 |
INTEGER, INTENT(IN):: szz ! Size of the zoom |
| 51 |
|
| 52 |
INTEGER, INTENT(IN):: zid |
| 53 |
! (ID of the vertical axis to use. It has to have the size of the zoom.) |
| 54 |
|
| 55 |
CHARACTER(len=*), INTENT(IN):: opp |
| 56 |
! Operation to be performed. The following options exist today: |
| 57 |
! inst: keeps instantaneous values for writting |
| 58 |
! ave: Computes the average from call between writes |
| 59 |
|
| 60 |
REAL, INTENT(IN):: pfreq_opp ! Frequency of this operation (in seconds) |
| 61 |
|
| 62 |
REAL, INTENT(IN):: pfreq_wrt |
| 63 |
! (Frequency at which the variable should be written, in seconds) |
| 64 |
|
| 65 |
! Local: |
| 66 |
|
| 67 |
INTEGER:: iv, i, nb |
| 68 |
CHARACTER(len=70):: str70, str71, str72 |
| 69 |
CHARACTER(len=20):: tmp_name |
| 70 |
CHARACTER(len=20):: str20, tab_str20(nb_var_max) |
| 71 |
INTEGER:: tab_str20_length(nb_var_max) |
| 72 |
CHARACTER(len=40):: str40, tab_str40(nb_var_max) |
| 73 |
INTEGER:: tab_str40_length(nb_var_max) |
| 74 |
CHARACTER(len=10):: str10 |
| 75 |
CHARACTER(len=80):: tmp_str80 |
| 76 |
CHARACTER(len=7):: tmp_topp, tmp_sopp(nbopp_max) |
| 77 |
CHARACTER(len=120):: ex_topps |
| 78 |
REAL:: tmp_scal(nbopp_max), un_an, un_jour, test_fopp, test_fwrt |
| 79 |
INTEGER:: pos, buff_sz |
| 80 |
|
| 81 |
!--------------------------------------------------------------------- |
| 82 |
|
| 83 |
ex_topps = 'ave, inst, t_min, t_max, t_sum, once, never, l_max, l_min' |
| 84 |
|
| 85 |
nb_var(fileid) = nb_var(fileid) + 1 |
| 86 |
iv = nb_var(fileid) |
| 87 |
|
| 88 |
IF (iv>nb_var_max) THEN |
| 89 |
CALL histerr(3, 'histdef', & |
| 90 |
'Table of variables too small. You should increase nb_var_max', & |
| 91 |
'in M_HISTCOM.f90 in order to accomodate all these variables', ' ') |
| 92 |
END IF |
| 93 |
|
| 94 |
! 1.0 Transfer informations on the variable to the common |
| 95 |
! and verify that it does not already exist |
| 96 |
|
| 97 |
IF (iv>1) THEN |
| 98 |
str20 = varname |
| 99 |
nb = iv - 1 |
| 100 |
tab_str20(1:nb) = name(fileid, 1:nb) |
| 101 |
tab_str20_length(1:nb) = name_length(fileid, 1:nb) |
| 102 |
CALL find_str(nb, tab_str20, tab_str20_length, str20, pos) |
| 103 |
ELSE |
| 104 |
pos = 0 |
| 105 |
END IF |
| 106 |
|
| 107 |
IF (pos>0) THEN |
| 108 |
str70 = 'Variable already exists' |
| 109 |
WRITE (str71, '("Check variable ", a, " in file", I3)') str20, & |
| 110 |
fileid |
| 111 |
str72 = 'Can also be a wrong file ID in another declaration' |
| 112 |
CALL histerr(3, 'histdef', str70, str71, str72) |
| 113 |
END IF |
| 114 |
|
| 115 |
name(fileid, iv) = varname |
| 116 |
name_length(fileid, iv) = len_trim(name(fileid, iv)) |
| 117 |
title(fileid, iv) = ptitle |
| 118 |
unit_name(fileid, iv) = unit |
| 119 |
tmp_name = name(fileid, iv) |
| 120 |
|
| 121 |
! 1.1 decode the operations |
| 122 |
|
| 123 |
fullop(fileid, iv) = opp |
| 124 |
tmp_str80 = opp |
| 125 |
CALL buildop(tmp_str80, ex_topps, tmp_topp, nbopp_max, missing_val, & |
| 126 |
tmp_sopp, tmp_scal, nbopp(fileid, iv)) |
| 127 |
|
| 128 |
topp(fileid, iv) = tmp_topp |
| 129 |
DO i = 1, nbopp(fileid, iv) |
| 130 |
sopps(fileid, iv, i) = tmp_sopp(i) |
| 131 |
scal(fileid, iv, i) = tmp_scal(i) |
| 132 |
END DO |
| 133 |
|
| 134 |
! 1.2 If we have an even number of operations |
| 135 |
! then we need to add identity |
| 136 |
|
| 137 |
IF (2*int(nbopp(fileid, iv)/2.0)==nbopp(fileid, iv)) THEN |
| 138 |
nbopp(fileid, iv) = nbopp(fileid, iv) + 1 |
| 139 |
sopps(fileid, iv, nbopp(fileid, iv)) = 'ident' |
| 140 |
scal(fileid, iv, nbopp(fileid, iv)) = missing_val |
| 141 |
END IF |
| 142 |
|
| 143 |
! 2.0 Put the size of the variable in the common and check |
| 144 |
|
| 145 |
scsize(fileid, iv, :) = (/ xsize, ysize, pzsize/) |
| 146 |
|
| 147 |
zorig(fileid, iv, 1:3) = (/ slab_ori(fileid, 1), slab_ori(fileid, 2), & |
| 148 |
oriz/) |
| 149 |
|
| 150 |
zsize(fileid, iv, 1:3) = (/ slab_sz(fileid, 1), slab_sz(fileid, 2), & |
| 151 |
szz/) |
| 152 |
|
| 153 |
! Is the size of the full array the same as that of the coordinates ? |
| 154 |
|
| 155 |
IF ((xsize>full_size(fileid, 1)) .OR. (ysize>full_size(fileid, & |
| 156 |
2))) THEN |
| 157 |
|
| 158 |
str70 = 'The size of the variable is different ' // & |
| 159 |
'from the one of the coordinates' |
| 160 |
WRITE (str71, '("Size of coordinates:", 2I4)') full_size(fileid, 1), & |
| 161 |
full_size(fileid, 2) |
| 162 |
WRITE (str72, '("Size declared for variable ", a, ":", 2I4)') & |
| 163 |
trim(tmp_name), xsize, ysize |
| 164 |
CALL histerr(3, 'histdef', str70, str71, str72) |
| 165 |
END IF |
| 166 |
|
| 167 |
! Is the size of the zoom smaler than the coordinates ? |
| 168 |
|
| 169 |
IF ((full_size(fileid, 1)<slab_sz(fileid, 1)) .OR. (full_size(fileid, & |
| 170 |
2)<slab_sz(fileid, 2))) THEN |
| 171 |
str70 = 'Size of variable should be greater or equal & |
| 172 |
&to those of the zoom' |
| 173 |
WRITE (str71, '("Size of XY zoom:", 2I4)') slab_sz(fileid, 1), & |
| 174 |
slab_sz(fileid, 1) |
| 175 |
WRITE (str72, '("Size declared for variable ", a, ":", 2I4)') & |
| 176 |
trim(tmp_name), xsize, ysize |
| 177 |
CALL histerr(3, 'histdef', str70, str71, str72) |
| 178 |
END IF |
| 179 |
|
| 180 |
! 2.1 We store the horizontal grid information with minimal |
| 181 |
! and a fall back onto the default grid |
| 182 |
|
| 183 |
IF (horiid>0 .AND. horiid<=nb_hax(fileid)) THEN |
| 184 |
var_haxid(fileid, iv) = horiid |
| 185 |
ELSE |
| 186 |
var_haxid(fileid, iv) = 1 |
| 187 |
CALL histerr(2, 'histdef', & |
| 188 |
'We use the default grid for variable as an invalide', & |
| 189 |
'ID was provided for variable: ', varname) |
| 190 |
END IF |
| 191 |
|
| 192 |
! 2.2 Check the vertical coordinates if needed |
| 193 |
|
| 194 |
IF (szz>1) THEN |
| 195 |
|
| 196 |
! Does the vertical coordinate exist ? |
| 197 |
|
| 198 |
IF (zid>nb_zax(fileid)) THEN |
| 199 |
WRITE (str70, '("The vertical coordinate chosen for variable ", a)' & |
| 200 |
) trim(tmp_name) |
| 201 |
str71 = ' Does not exist.' |
| 202 |
CALL histerr(3, 'histdef', str70, str71, ' ') |
| 203 |
END IF |
| 204 |
|
| 205 |
! Is the vertical size of the variable equal to that of the axis ? |
| 206 |
|
| 207 |
IF (szz/=zax_size(fileid, zid)) THEN |
| 208 |
str20 = zax_name(fileid, zid) |
| 209 |
str70 = 'The size of the zoom does not correspond ' // & |
| 210 |
'to the size of the chosen vertical axis' |
| 211 |
WRITE (str71, '("Size of zoom in z:", I4)') szz |
| 212 |
WRITE (str72, '("Size declared for axis ", a, ":", I4)') & |
| 213 |
trim(str20), zax_size(fileid, zid) |
| 214 |
CALL histerr(3, 'histdef', str70, str71, str72) |
| 215 |
END IF |
| 216 |
|
| 217 |
! Is the zoom smaler that the total size of the variable ? |
| 218 |
|
| 219 |
IF (pzsize<szz) THEN |
| 220 |
str20 = zax_name(fileid, zid) |
| 221 |
str70 = 'The vertical size of variable ' // & |
| 222 |
'is smaller than that of the zoom.' |
| 223 |
WRITE (str71, '("Declared vertical size of data:", I5)') pzsize |
| 224 |
WRITE (str72, '("Size of zoom for variable ", a, " = ", I5)') & |
| 225 |
trim(tmp_name), szz |
| 226 |
CALL histerr(3, 'histdef', str70, str71, str72) |
| 227 |
END IF |
| 228 |
var_zaxid(fileid, iv) = zid |
| 229 |
ELSE |
| 230 |
var_zaxid(fileid, iv) = -99 |
| 231 |
END IF |
| 232 |
|
| 233 |
! 3.0 Determine the position of the variable in the buffer |
| 234 |
! If it is instantaneous output then we do not use the buffer |
| 235 |
|
| 236 |
! 3.1 We get the size of the arrays histwrite will get and check |
| 237 |
! that they fit into the tmp_buffer |
| 238 |
|
| 239 |
buff_sz = zsize(fileid, iv, 1)*zsize(fileid, iv, 2)*zsize(fileid, iv, 3) |
| 240 |
|
| 241 |
! 3.2 move the pointer of the buffer array for operation |
| 242 |
! which need bufferisation |
| 243 |
|
| 244 |
IF ((trim(tmp_topp)/='inst') .AND. (trim(tmp_topp)/='once') .AND. ( & |
| 245 |
trim(tmp_topp)/='never')) THEN |
| 246 |
point(fileid, iv) = buff_pos + 1 |
| 247 |
buff_pos = buff_pos + buff_sz |
| 248 |
END IF |
| 249 |
|
| 250 |
! 4.0 Transfer the frequency of the operations and check |
| 251 |
! for validity. We have to pay attention to negative values |
| 252 |
! of the frequency which indicate monthly time-steps. |
| 253 |
! The strategy is to bring it back to seconds for the tests |
| 254 |
|
| 255 |
freq_opp(fileid, iv) = pfreq_opp |
| 256 |
freq_wrt(fileid, iv) = pfreq_wrt |
| 257 |
|
| 258 |
CALL ioget_calendar(un_an, un_jour) |
| 259 |
IF (pfreq_opp<0) THEN |
| 260 |
CALL ioget_calendar(un_an) |
| 261 |
test_fopp = pfreq_opp*(-1.)*un_an/12.*un_jour |
| 262 |
ELSE |
| 263 |
test_fopp = pfreq_opp |
| 264 |
END IF |
| 265 |
IF (pfreq_wrt<0) THEN |
| 266 |
CALL ioget_calendar(un_an) |
| 267 |
test_fwrt = pfreq_wrt*(-1.)*un_an/12.*un_jour |
| 268 |
ELSE |
| 269 |
test_fwrt = pfreq_wrt |
| 270 |
END IF |
| 271 |
|
| 272 |
! 4.1 Frequency of operations and output should be larger than deltat ! |
| 273 |
|
| 274 |
IF (test_fopp<deltat(fileid)) THEN |
| 275 |
str70 = 'Frequency of operations should be larger than deltat' |
| 276 |
WRITE (str71, '("It is not the case for variable ", a, ":", F10.4)') & |
| 277 |
trim(tmp_name), pfreq_opp |
| 278 |
str72 = 'PATCH: frequency set to deltat' |
| 279 |
|
| 280 |
CALL histerr(2, 'histdef', str70, str71, str72) |
| 281 |
|
| 282 |
freq_opp(fileid, iv) = deltat(fileid) |
| 283 |
END IF |
| 284 |
|
| 285 |
IF (test_fwrt<deltat(fileid)) THEN |
| 286 |
str70 = 'Frequency of output should be larger than deltat' |
| 287 |
WRITE (str71, '("It is not the case for variable ", a, ":", F10.4)') & |
| 288 |
trim(tmp_name), pfreq_wrt |
| 289 |
str72 = 'PATCH: frequency set to deltat' |
| 290 |
|
| 291 |
CALL histerr(2, 'histdef', str70, str71, str72) |
| 292 |
|
| 293 |
freq_wrt(fileid, iv) = deltat(fileid) |
| 294 |
END IF |
| 295 |
|
| 296 |
! 4.2 First the existence of the operation is tested and then |
| 297 |
! its compatibility with the choice of frequencies |
| 298 |
|
| 299 |
IF (trim(tmp_topp)=='inst') THEN |
| 300 |
IF (test_fopp/=test_fwrt) THEN |
| 301 |
str70 = 'For instantaneous output the frequency ' // & |
| 302 |
'of operations and output' |
| 303 |
WRITE (str71, & |
| 304 |
'("should be the same, this was not case for variable ", a)') & |
| 305 |
trim(tmp_name) |
| 306 |
str72 = 'PATCH: The smalest frequency of both is used' |
| 307 |
CALL histerr(2, 'histdef', str70, str71, str72) |
| 308 |
IF (test_fopp<test_fwrt) THEN |
| 309 |
freq_opp(fileid, iv) = pfreq_opp |
| 310 |
freq_wrt(fileid, iv) = pfreq_opp |
| 311 |
ELSE |
| 312 |
freq_opp(fileid, iv) = pfreq_wrt |
| 313 |
freq_wrt(fileid, iv) = pfreq_wrt |
| 314 |
END IF |
| 315 |
END IF |
| 316 |
ELSE IF (index(ex_topps, trim(tmp_topp))>0) THEN |
| 317 |
IF (test_fopp>test_fwrt) THEN |
| 318 |
str70 = 'For averages the frequency of operations ' // & |
| 319 |
'should be smaller or equal' |
| 320 |
WRITE (str71, & |
| 321 |
'("to that of output. It is not the case for variable ", a)') & |
| 322 |
trim(tmp_name) |
| 323 |
str72 = 'PATCH: The output frequency is used for both' |
| 324 |
CALL histerr(2, 'histdef', str70, str71, str72) |
| 325 |
freq_opp(fileid, iv) = pfreq_wrt |
| 326 |
END IF |
| 327 |
ELSE |
| 328 |
WRITE (str70, '("Operation on variable ", a, " is unknown")') & |
| 329 |
trim(tmp_name) |
| 330 |
WRITE (str71, '("operation requested is:", a)') tmp_topp |
| 331 |
WRITE (str72, '("File ID:", I3)') fileid |
| 332 |
CALL histerr(3, 'histdef', str70, str71, str72) |
| 333 |
END IF |
| 334 |
|
| 335 |
! 5.0 Initialize other variables of the common |
| 336 |
|
| 337 |
last_opp(fileid, iv) = itau0(fileid) |
| 338 |
! - freq_opp(fileid, iv)/2./deltat(fileid) |
| 339 |
last_wrt(fileid, iv) = itau0(fileid) |
| 340 |
! - freq_wrt(fileid, iv)/2./deltat(fileid) |
| 341 |
last_opp_chk(fileid, iv) = itau0(fileid) |
| 342 |
! - freq_opp(fileid, iv)/2./deltat(fileid) |
| 343 |
last_wrt_chk(fileid, iv) = itau0(fileid) |
| 344 |
! - freq_wrt(fileid, iv)/2./deltat(fileid) |
| 345 |
nb_opp(fileid, iv) = 0 |
| 346 |
nb_wrt(fileid, iv) = 0 |
| 347 |
|
| 348 |
! 6.0 Get the time axis for this variable |
| 349 |
|
| 350 |
IF (freq_wrt(fileid, iv)>0) THEN |
| 351 |
WRITE (str10, '(I8.8)') int(freq_wrt(fileid, iv)) |
| 352 |
str40 = trim(tmp_topp) // '_' // trim(str10) |
| 353 |
ELSE |
| 354 |
WRITE (str10, '(I2.2, "month")') abs(int(freq_wrt(fileid, iv))) |
| 355 |
str40 = trim(tmp_topp) // '_' // trim(str10) |
| 356 |
END IF |
| 357 |
|
| 358 |
DO i = 1, nb_tax(fileid) |
| 359 |
tab_str40(i) = tax_name(fileid, i) |
| 360 |
tab_str40_length(i) = tax_name_length(fileid, i) |
| 361 |
END DO |
| 362 |
|
| 363 |
CALL find_str(nb_tax(fileid), tab_str40, tab_str40_length, str40, pos) |
| 364 |
|
| 365 |
! No time axis for once, l_max, l_min or never operation |
| 366 |
|
| 367 |
IF ((trim(tmp_topp)/='once') .AND. (trim(tmp_topp)/='never') .AND. ( & |
| 368 |
trim(tmp_topp)/='l_max') .AND. (trim(tmp_topp)/='l_min')) THEN |
| 369 |
IF (pos<0) THEN |
| 370 |
nb_tax(fileid) = nb_tax(fileid) + 1 |
| 371 |
tax_name(fileid, nb_tax(fileid)) = str40 |
| 372 |
tax_name_length(fileid, nb_tax(fileid)) = len_trim(str40) |
| 373 |
tax_last(fileid, nb_tax(fileid)) = 0 |
| 374 |
var_axid(fileid, iv) = nb_tax(fileid) |
| 375 |
ELSE |
| 376 |
var_axid(fileid, iv) = pos |
| 377 |
END IF |
| 378 |
ELSE |
| 379 |
var_axid(fileid, iv) = -99 |
| 380 |
END IF |
| 381 |
|
| 382 |
! 7.0 prepare frequence of writing and operation |
| 383 |
! for never or once operation |
| 384 |
|
| 385 |
IF ((trim(tmp_topp)=='once') .OR. (trim(tmp_topp)=='never')) THEN |
| 386 |
freq_opp(fileid, iv) = 0. |
| 387 |
freq_wrt(fileid, iv) = 0. |
| 388 |
END IF |
| 389 |
|
| 390 |
END SUBROUTINE histdef |
| 391 |
|
| 392 |
end module histdef_m |
Parent Directory
| 
Revision Log