Changeset 760 for IOIPSL/trunk/src
- Timestamp:
- 10/26/09 15:10:32 (15 years ago)
- Location:
- IOIPSL/trunk/src
- Files:
-
- 2 edited
-
fliocom.f90 (modified) (2 diffs)
-
histcom.f90 (modified) (115 diffs)
Legend:
- Unmodified
- Added
- Removed
-
IOIPSL/trunk/src/fliocom.f90
r386 r760 883 883 IF (PRESENT(mode)) THEN 884 884 SELECT CASE (TRIM(mode)) 885 CASE('REPLACE','REP','REP32') 885 CASE('REPLACE','REP','REP64') 886 m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) 887 CASE('REP32') 886 888 m_c = NF90_CLOBBER 887 889 CASE('32') … … 889 891 CASE('64') 890 892 m_c = IOR(NF90_NOCLOBBER,NF90_64BIT_OFFSET) 891 CASE('REP64')892 m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET)893 893 CASE DEFAULT 894 m_c = NF90_NOCLOBBER894 m_c = IOR(NF90_NOCLOBBER,NF90_64BIT_OFFSET) 895 895 END SELECT 896 896 ELSE 897 m_c = NF90_NOCLOBBER897 m_c = IOR(NF90_NOCLOBBER,NF90_64BIT_OFFSET) 898 898 ENDIF 899 899 !- -
IOIPSL/trunk/src/histcom.f90
r752 r760 35 35 !- to describe the grid, just two vectors. 36 36 !--------------------------------------------------------------------- 37 !- 38 INTERFACE histbeg 39 MODULE PROCEDURE histbeg_totreg,histbeg_regular,histbeg_irregular 40 END INTERFACE 41 !- 42 INTERFACE histhori 43 MODULE PROCEDURE histhori_regular,histhori_irregular 44 END INTERFACE 45 !- 37 46 INTERFACE histwrite 38 47 !--------------------------------------------------------------------- … … 63 72 END INTERFACE 64 73 !- 65 INTERFACE histbeg66 MODULE PROCEDURE histbeg_totreg,histbeg_regular,histbeg_irregular67 END INTERFACE68 !-69 INTERFACE histhori70 MODULE PROCEDURE histhori_regular,histhori_irregular71 END INTERFACE72 !-73 74 ! Fixed parameter 74 75 !- … … 79 80 & hist_r4=nf90_real4, hist_r8=nf90_real8 80 81 !- 81 INTEGER :: bufftmp_max(nb_files_max) = 1 82 !- 83 ! Time variables 84 !- 85 INTEGER,SAVE :: itau0(nb_files_max)=0 86 REAL,DIMENSION(nb_files_max),SAVE ::date0,deltat 82 ! Variable derived type 83 !- 84 TYPE T_D_V 85 INTEGER :: ncvid 86 INTEGER :: nbopp 87 CHARACTER(LEN=20) :: v_name,unit_name 88 CHARACTER(LEN=80) :: title,fullop 89 CHARACTER(LEN=7) :: topp 90 CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopps 91 REAL,DIMENSION(nbopp_max) :: scal 92 !-External type (for R4/R8) 93 INTEGER :: v_typ 94 !-Sizes of the associated grid and zommed area 95 INTEGER,DIMENSION(3) :: scsize,zorig,zsize 96 !-Sizes for the data as it goes through the various math operations 97 INTEGER,DIMENSION(3) :: datasz_in = -1 98 INTEGER :: datasz_max = -1 99 !- 100 INTEGER :: h_axid,z_axid,t_axid 101 !- 102 REAL,DIMENSION(2) :: hist_minmax 103 LOGICAL :: hist_calc_rng=.FALSE.,hist_wrt_rng=.FALSE. 104 !-Book keeping of the axes 105 INTEGER :: tdimid,tax_last 106 CHARACTER(LEN=40) :: tax_name 107 !- 108 REAL :: freq_opp,freq_wrt 109 INTEGER :: & 110 & last_opp,last_wrt,last_opp_chk,last_wrt_chk,nb_opp,nb_wrt,point 111 !- For future optimization 112 !# REAL,ALLOCATABLE,DIMENSION(:) :: V_1_D 113 !# REAL,ALLOCATABLE,DIMENSION(:,:) :: V_2_D 114 !# REAL,ALLOCATABLE,DIMENSION(:,:,:) :: V_3_D 115 END TYPE T_D_V 116 !- 117 ! File derived type 118 !- 119 TYPE :: T_D_F 120 !-NETCDF IDs for file 121 INTEGER :: ncfid 122 !-Time variables 123 INTEGER :: itau0=0 124 REAL :: date0,deltat 125 !-Counter of elements (variables, time-horizontal-vertical axis 126 INTEGER :: n_var=0,n_tax=0,n_hax=0,n_zax=0 127 !-NETCDF dimension IDs for time-longitude-latitude 128 INTEGER :: tid,xid,yid 129 !-General definitions in the NETCDF file 130 INTEGER,DIMENSION(2) :: full_size=0,slab_ori,slab_sz 131 !-The horizontal axes 132 CHARACTER(LEN=25),DIMENSION(nb_hax_max,2) :: hax_name 133 !-The vertical axes 134 INTEGER,DIMENSION(nb_zax_max) :: zax_size,zax_ids 135 CHARACTER(LEN=20),DIMENSION(nb_zax_max) :: zax_name 136 !- 137 LOGICAL :: regular=.TRUE. 138 !-DOMAIN ID 139 INTEGER :: dom_id_svg=-1 140 !- 141 TYPE(T_D_V),DIMENSION(nb_var_max) :: W_V 142 END TYPE T_D_F 143 !- 144 TYPE(T_D_F),DIMENSION(nb_files_max),SAVE :: W_F 87 145 !- 88 146 ! Counter of elements 89 147 !- 90 148 INTEGER,SAVE :: nb_files=0 91 INTEGER,DIMENSION(nb_files_max),SAVE :: nb_var=0,nb_tax=092 !-93 ! DOMAIN IDs for files94 !-95 INTEGER,DIMENSION(nb_files_max),SAVE :: dom_id_svg=-196 !-97 ! NETCDF IDs for files and axes98 !-99 INTEGER,DIMENSION(nb_files_max),SAVE :: ncdf_ids,xid,yid,tid100 !-101 ! General definitions in the NETCDF file102 !-103 INTEGER,DIMENSION(nb_files_max,2),SAVE :: &104 & full_size=0,slab_ori,slab_sz105 !-106 ! The horizontal axes107 !-108 INTEGER,SAVE :: nb_hax(nb_files_max)=0109 CHARACTER(LEN=25),SAVE :: hax_name(nb_files_max,nb_hax_max,2)110 !-111 ! The vertical axes112 !-113 INTEGER,SAVE :: nb_zax(nb_files_max)=0114 INTEGER,DIMENSION(nb_files_max,nb_zax_max),SAVE :: &115 & zax_size,zax_ids116 CHARACTER(LEN=20),SAVE :: zax_name(nb_files_max,nb_zax_max)117 !-118 ! Informations on each variable119 !-120 INTEGER,DIMENSION(nb_files_max,nb_var_max),SAVE :: v_typ121 CHARACTER(LEN=20),DIMENSION(nb_files_max,nb_var_max),SAVE :: &122 & name,unit_name123 CHARACTER(LEN=80),DIMENSION(nb_files_max,nb_var_max),SAVE :: &124 & title,fullop125 CHARACTER(LEN=7),SAVE :: topp(nb_files_max,nb_var_max)126 CHARACTER(LEN=7),SAVE :: sopps(nb_files_max,nb_var_max,nbopp_max)127 REAL,SAVE :: scal(nb_files_max,nb_var_max,nbopp_max)128 !- Sizes of the associated grid and zommed area129 INTEGER,DIMENSION(nb_files_max,nb_var_max,3),SAVE :: &130 & scsize,zorig,zsize131 !- Sizes for the data as it goes through the various math operations132 INTEGER,SAVE :: datasz_in(nb_files_max,nb_var_max,3) = -1133 INTEGER,SAVE :: datasz_max(nb_files_max,nb_var_max) = -1134 !-135 INTEGER,DIMENSION(nb_files_max,nb_var_max),SAVE :: &136 & var_haxid,var_zaxid,var_axid,ncvar_ids137 !-138 REAL,DIMENSION(nb_files_max,nb_var_max,2),SAVE :: hist_minmax139 LOGICAL,DIMENSION(nb_files_max,nb_var_max),SAVE :: &140 & hist_calc_rng=.FALSE.,hist_wrt_rng=.FALSE.141 !-142 REAL,DIMENSION(nb_files_max,nb_var_max),SAVE :: &143 & freq_opp,freq_wrt144 INTEGER,DIMENSION(nb_files_max,nb_var_max),SAVE :: &145 & nbopp,last_opp,last_wrt,last_opp_chk,last_wrt_chk,nb_opp,nb_wrt,point146 149 !- 147 150 ! Book keeping for the buffers … … 149 152 INTEGER,SAVE :: buff_pos=0 150 153 REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buffer 151 LOGICAL,DIMENSION(nb_files_max),SAVE :: zoom=.FALSE.,regular=.TRUE.152 !-153 ! Book keeping of the axes154 !-155 INTEGER,DIMENSION(nb_files_max,nb_var_max),SAVE :: &156 & tdimid,tax_last157 CHARACTER(LEN=40),DIMENSION(nb_files_max,nb_var_max),SAVE :: &158 & tax_name159 154 !- 160 155 ! A list of functions which require special action … … 162 157 ! but they are well located here) 163 158 !- 164 CHARACTER(LEN=120),SAVE :: & 165 & indchfun = 'scatter, fill, gather, coll', & 166 & fuchnbout = 'scatter, fill' 159 CHARACTER(LEN=30),SAVE :: fuchnbout = 'scatter, fill' 167 160 !- Some configurable variables with locks 168 161 CHARACTER(LEN=80),SAVE :: model_name='An IPSL model' … … 176 169 & (pfilename,pim,plon,pjm,plat, & 177 170 & par_orix,par_szx,par_oriy,par_szy, & 178 & pitau0,pdate0,pdeltat,phoriid,pfileid,domain_id )171 & pitau0,pdate0,pdeltat,phoriid,pfileid,domain_id,nb_bits) 179 172 !--------------------------------------------------------------------- 180 173 !- This is just an interface for histbeg_regular in case when … … 202 195 !- pitau0 : time step at which the history tape starts 203 196 !- pdate0 : The Julian date at which the itau was equal to 0 204 !- pdeltat : Time step in seconds. Time stepof the counter itau197 !- pdeltat : Time step, in seconds, of the counter itau 205 198 !- used in histwrite for instance 206 199 !- … … 235 228 REAL,INTENT(IN) :: pdate0,pdeltat 236 229 INTEGER,INTENT(OUT) :: pfileid,phoriid 237 INTEGER,INTENT(IN),OPTIONAL :: domain_id 230 INTEGER,INTENT(IN),OPTIONAL :: domain_id,nb_bits 238 231 !- 239 232 REAL,ALLOCATABLE,DIMENSION(:,:) :: lon_tmp,lat_tmp … … 253 246 & par_orix,par_szx,par_oriy,par_szy, & 254 247 & pitau0,pdate0,pdeltat,phoriid,pfileid, & 255 & .TRUE.,domain_id )248 & .TRUE.,domain_id,nb_bits) 256 249 !- 257 250 DEALLOCATE(lon_tmp,lat_tmp) … … 263 256 & par_orix,par_szx,par_oriy,par_szy, & 264 257 & pitau0,pdate0,pdeltat,phoriid,pfileid, & 265 & opt_rectilinear,domain_id )258 & opt_rectilinear,domain_id,nb_bits) 266 259 !--------------------------------------------------------------------- 267 260 !- This subroutine initializes a netcdf file and returns the ID. … … 290 283 !- pitau0 : time step at which the history tape starts 291 284 !- pdate0 : The Julian date at which the itau was equal to 0 292 !- pdeltat : Time step in seconds. Time stepof the counter itau285 !- pdeltat : Time step, in seconds, of the counter itau 293 286 !- used in histwrite for instance 294 287 !- … … 324 317 INTEGER,INTENT(OUT) :: pfileid,phoriid 325 318 LOGICAL,INTENT(IN),OPTIONAL :: opt_rectilinear 326 INTEGER,INTENT(IN),OPTIONAL :: domain_id 327 !- 328 INTEGER :: n cid,iret319 INTEGER,INTENT(IN),OPTIONAL :: domain_id,nb_bits 320 !- 321 INTEGER :: nfid,iret,m_c 329 322 CHARACTER(LEN=120) :: file 330 323 CHARACTER(LEN=30) :: timenow … … 334 327 CALL ipsldbg (old_status=l_dbg) 335 328 !- 329 IF (l_dbg) WRITE(*,*) "histbeg_regular 0.0" 330 !- 336 331 nb_files = nb_files+1 337 pfileid = nb_files338 !-339 ! 1.0 Transfering into the common for future use340 !-341 IF (l_dbg) WRITE(*,*) "histbeg_regular 1.0"342 !-343 itau0(pfileid) = pitau0344 date0(pfileid) = pdate0345 deltat(pfileid) = pdeltat346 !-347 IF (PRESENT(opt_rectilinear)) THEN348 rectilinear = opt_rectilinear349 ELSE350 rectilinear = .FALSE.351 ENDIF352 !-353 ! 2.0 Initializes all variables for this file354 !-355 IF (l_dbg) WRITE(*,*) "histbeg_regular 2.0"356 !-357 332 IF (nb_files > nb_files_max) THEN 358 333 CALL ipslerr (3,"histbeg", & … … 360 335 & 'in histcom.f90 in order to accomodate all these files',' ') 361 336 ENDIF 362 !- 363 nb_var(pfileid) = 0 364 nb_tax(pfileid) = 0 365 nb_hax(pfileid) = 0 366 nb_zax(pfileid) = 0 367 !- 368 slab_ori(pfileid,1:2) = (/ par_orix,par_oriy /) 369 slab_sz(pfileid,1:2) = (/ par_szx, par_szy /) 337 pfileid = nb_files 338 !- 339 ! 1.0 Transfering into the common for future use 340 !- 341 IF (l_dbg) WRITE(*,*) "histbeg_regular 1.0" 342 !- 343 W_F(pfileid)%itau0 = pitau0 344 W_F(pfileid)%date0 = pdate0 345 W_F(pfileid)%deltat = pdeltat 346 !- 347 IF (PRESENT(opt_rectilinear)) THEN 348 rectilinear = opt_rectilinear 349 ELSE 350 rectilinear = .FALSE. 351 ENDIF 352 !- 353 ! 2.0 Initializes all variables for this file 354 !- 355 IF (l_dbg) WRITE(*,*) "histbeg_regular 2.0" 356 !- 357 W_F(pfileid)%n_var = 0 358 W_F(pfileid)%n_tax = 0 359 W_F(pfileid)%n_hax = 0 360 W_F(pfileid)%n_zax = 0 361 !- 362 W_F(pfileid)%slab_ori(1:2) = (/ par_orix,par_oriy /) 363 W_F(pfileid)%slab_sz(1:2) = (/ par_szx, par_szy /) 370 364 !- 371 365 ! 3.0 Opening netcdf file and defining dimensions … … 378 372 CALL flio_dom_file (file,domain_id) 379 373 !- 380 iret = NF90_CREATE (file,NF90_CLOBBER,ncid) 374 ! Check the mode 375 IF (PRESENT(nb_bits)) THEN 376 SELECT CASE (nb_bits) 377 CASE(32) 378 m_c = NF90_CLOBBER 379 CASE(64) 380 m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) 381 CASE DEFAULT 382 CALL ipslerr (3,"histbeg", & 383 & 'Invalid argument nb_bits for file :',TRIM(file), & 384 & 'Supported values are 32 or 64') 385 END SELECT 386 ELSE 387 m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) 388 ENDIF 389 !- 390 ! Create file 391 iret = NF90_CREATE (file,m_c,nfid) 381 392 !- 382 393 IF (rectilinear) THEN 383 iret = NF90_DEF_DIM (n cid,'lon',par_szx,xid(nb_files))384 iret = NF90_DEF_DIM (n cid,'lat',par_szy,yid(nb_files))385 ELSE 386 iret = NF90_DEF_DIM (n cid,'x',par_szx,xid(nb_files))387 iret = NF90_DEF_DIM (n cid,'y',par_szy,yid(nb_files))394 iret = NF90_DEF_DIM (nfid,'lon',par_szx,W_F(pfileid)%xid) 395 iret = NF90_DEF_DIM (nfid,'lat',par_szy,W_F(pfileid)%yid) 396 ELSE 397 iret = NF90_DEF_DIM (nfid,'x',par_szx,W_F(pfileid)%xid) 398 iret = NF90_DEF_DIM (nfid,'y',par_szy,W_F(pfileid)%yid) 388 399 ENDIF 389 400 !- … … 394 405 ! 4.3 Global attributes 395 406 !- 396 iret = NF90_PUT_ATT (n cid,NF90_GLOBAL,'Conventions','CF-1.1')397 iret = NF90_PUT_ATT (n cid,NF90_GLOBAL,'file_name',TRIM(file))398 iret = NF90_PUT_ATT (n cid,NF90_GLOBAL,'production',TRIM(model_name))407 iret = NF90_PUT_ATT (nfid,NF90_GLOBAL,'Conventions','CF-1.1') 408 iret = NF90_PUT_ATT (nfid,NF90_GLOBAL,'file_name',TRIM(file)) 409 iret = NF90_PUT_ATT (nfid,NF90_GLOBAL,'production',TRIM(model_name)) 399 410 lock_modname = .TRUE. 400 411 CALL ioget_timestamp (timenow) 401 iret = NF90_PUT_ATT (n cid,NF90_GLOBAL,'TimeStamp',TRIM(timenow))412 iret = NF90_PUT_ATT (nfid,NF90_GLOBAL,'TimeStamp',TRIM(timenow)) 402 413 !- 403 414 ! 5.0 Saving some important information on this file in the common … … 406 417 !- 407 418 IF (PRESENT(domain_id)) THEN 408 dom_id_svg(pfileid)= domain_id409 ENDIF 410 ncdf_ids(pfileid) = ncid411 full_size(pfileid,1:2) = (/ pim,pjm /)419 W_F(pfileid)%dom_id_svg = domain_id 420 ENDIF 421 W_F(pfileid)%ncfid = nfid 422 W_F(pfileid)%full_size(1:2) = (/ pim,pjm /) 412 423 !- 413 424 ! 6.0 storing the geographical coordinates 414 425 !- 415 zoom(pfileid) = (pim /= par_szx).OR.(pjm /= par_szy) 416 regular(pfileid)=.TRUE. 426 W_F(pfileid)%regular=.TRUE. 417 427 !- 418 428 CALL histhori_regular (pfileid,pim,plon,pjm,plat, & 419 & ' ' 429 & ' ','Default grid',phoriid,rectilinear) 420 430 !----------------------------- 421 431 END SUBROUTINE histbeg_regular … … 423 433 SUBROUTINE histbeg_irregular & 424 434 & (pfilename,pim,plon,plon_bounds,plat,plat_bounds, & 425 & pitau0,pdate0,pdeltat,phoriid,pfileid,domain_id )435 & pitau0,pdate0,pdeltat,phoriid,pfileid,domain_id,nb_bits) 426 436 !--------------------------------------------------------------------- 427 437 !- This subroutine initializes a netcdf file and returns the ID. … … 442 452 !- pitau0 : time step at which the history tape starts 443 453 !- pdate0 : The Julian date at which the itau was equal to 0 444 !- pdeltat : Time step in seconds. Time stepof the counter itau454 !- pdeltat : Time step, in seconds, of the counter itau 445 455 !- used in histwrite for instance 446 456 !- … … 474 484 REAL,INTENT(IN) :: pdate0,pdeltat 475 485 INTEGER,INTENT(OUT) :: pfileid,phoriid 476 INTEGER,INTENT(IN),OPTIONAL :: domain_id 477 !- 478 INTEGER :: n cid,iret486 INTEGER,INTENT(IN),OPTIONAL :: domain_id,nb_bits 487 !- 488 INTEGER :: nfid,iret,m_c 479 489 CHARACTER(LEN=120) :: file 480 490 CHARACTER(LEN=30) :: timenow … … 483 493 CALL ipsldbg (old_status=l_dbg) 484 494 !- 495 IF (l_dbg) WRITE(*,*) "histbeg_irregular 0.0" 496 !- 485 497 nb_files = nb_files+1 486 pfileid = nb_files487 !-488 ! 1.0 Transfering into the common for future use489 !-490 IF (l_dbg) WRITE(*,*) "histbeg_irregular 1.0"491 !-492 itau0(pfileid) = pitau0493 date0(pfileid) = pdate0494 deltat(pfileid) = pdeltat495 !-496 ! 2.0 Initializes all variables for this file497 !-498 IF (l_dbg) WRITE(*,*) "histbeg_irregular 2.0"499 !-500 498 IF (nb_files > nb_files_max) THEN 501 499 CALL ipslerr (3,"histbeg", & 502 & 'Table of files too small. You should increase nb_files_max', & 503 & 'in histcom.f90 in order to accomodate all these files',' ') 504 ENDIF 505 !- 506 nb_var(pfileid) = 0 507 nb_tax(pfileid) = 0 508 nb_hax(pfileid) = 0 509 nb_zax(pfileid) = 0 510 !- 511 slab_ori(pfileid,1:2) = (/ 1,1 /) 512 slab_sz(pfileid,1:2) = (/ pim,1 /) 500 & 'Table of files too small. You should increase nb_files_max', & 501 & 'in histcom.f90 in order to accomodate all these files',' ') 502 ENDIF 503 pfileid = nb_files 504 !- 505 ! 1.0 Transfering into the common for future use 506 !- 507 IF (l_dbg) WRITE(*,*) "histbeg_irregular 1.0" 508 !- 509 W_F(pfileid)%itau0 = pitau0 510 W_F(pfileid)%date0 = pdate0 511 W_F(pfileid)%deltat = pdeltat 512 !- 513 ! 2.0 Initializes all variables for this file 514 !- 515 IF (l_dbg) WRITE(*,*) "histbeg_irregular 2.0" 516 !- 517 W_F(pfileid)%n_var = 0 518 W_F(pfileid)%n_tax = 0 519 W_F(pfileid)%n_hax = 0 520 W_F(pfileid)%n_zax = 0 521 !- 522 W_F(pfileid)%slab_ori(1:2) = (/ 1,1 /) 523 W_F(pfileid)%slab_sz(1:2) = (/ pim,1 /) 513 524 !- 514 525 ! 3.0 Opening netcdf file and defining dimensions … … 521 532 CALL flio_dom_file (file,domain_id) 522 533 !- 523 iret = NF90_CREATE (file,NF90_CLOBBER,ncid) 524 !- 525 iret = NF90_DEF_DIM (ncid,'x',pim,xid(nb_files)) 526 yid(nb_files) = 0 534 ! Check the mode 535 IF (PRESENT(nb_bits)) THEN 536 SELECT CASE (nb_bits) 537 CASE(32) 538 m_c = NF90_CLOBBER 539 CASE(64) 540 m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) 541 CASE DEFAULT 542 CALL ipslerr (3,"histbeg", & 543 & 'Invalid argument nb_bits for file :',TRIM(file), & 544 & 'Supported values are 32 or 64') 545 END SELECT 546 ELSE 547 m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) 548 ENDIF 549 !- 550 ! Create file 551 iret = NF90_CREATE (file,m_c,nfid) 552 !- 553 iret = NF90_DEF_DIM (nfid,'x',pim,W_F(pfileid)%xid) 554 W_F(pfileid)%yid = 0 527 555 !- 528 556 ! 4.0 Declaring the geographical coordinates and other attributes … … 532 560 ! 4.3 Global attributes 533 561 !- 534 iret = NF90_PUT_ATT (n cid,NF90_GLOBAL,'Conventions','CF-1.1')535 iret = NF90_PUT_ATT (n cid,NF90_GLOBAL,'file_name',TRIM(file))536 iret = NF90_PUT_ATT (n cid,NF90_GLOBAL,'production',TRIM(model_name))562 iret = NF90_PUT_ATT (nfid,NF90_GLOBAL,'Conventions','CF-1.1') 563 iret = NF90_PUT_ATT (nfid,NF90_GLOBAL,'file_name',TRIM(file)) 564 iret = NF90_PUT_ATT (nfid,NF90_GLOBAL,'production',TRIM(model_name)) 537 565 lock_modname = .TRUE. 538 566 CALL ioget_timestamp (timenow) 539 iret = NF90_PUT_ATT (n cid,NF90_GLOBAL,'TimeStamp',TRIM(timenow))567 iret = NF90_PUT_ATT (nfid,NF90_GLOBAL,'TimeStamp',TRIM(timenow)) 540 568 !- 541 569 ! 5.0 Saving some important information on this file in the common … … 544 572 !- 545 573 IF (PRESENT(domain_id)) THEN 546 dom_id_svg(pfileid)= domain_id547 ENDIF 548 ncdf_ids(pfileid) = ncid549 full_size(pfileid,1:2) = (/ pim,1 /)574 W_F(pfileid)%dom_id_svg = domain_id 575 ENDIF 576 W_F(pfileid)%ncfid = nfid 577 W_F(pfileid)%full_size(1:2) = (/ pim,1 /) 550 578 !- 551 579 ! 6.0 storing the geographical coordinates 552 580 !- 553 zoom(pfileid)=.FALSE. 554 regular(pfileid)=.FALSE. 581 W_F(pfileid)%regular=.FALSE. 555 582 !- 556 583 CALL histhori_irregular & 557 584 & (pfileid,pim,plon,plon_bounds,plat,plat_bounds, & 558 & ' ' 585 & ' ','Default grid',phoriid) 559 586 !------------------------------- 560 587 END SUBROUTINE histbeg_irregular … … 604 631 INTEGER :: nlonid,nlatid 605 632 INTEGER :: orix,oriy,par_szx,par_szy 606 INTEGER :: iret,n cid633 INTEGER :: iret,nfid 607 634 LOGICAL :: rectilinear 608 635 LOGICAL :: l_dbg … … 612 639 ! 1.0 Check that all fits in the buffers 613 640 !- 614 IF ( (pim /= full_size(pfileid,1)) &615 & .OR.(pjm /= full_size(pfileid,2)) ) THEN641 IF ( (pim /= W_F(pfileid)%full_size(1)) & 642 & .OR.(pjm /= W_F(pfileid)%full_size(2)) ) THEN 616 643 CALL ipslerr (3,"histhori", & 617 &'The new horizontal grid does not have the same size', &618 &'as the one provided to histbeg. This is not yet ', &619 &'possible in the hist package.')644 & 'The new horizontal grid does not have the same size', & 645 & 'as the one provided to histbeg. This is not yet ', & 646 & 'possible in the hist package.') 620 647 ENDIF 621 648 !- … … 630 657 IF (l_dbg) WRITE(*,*) "histhori_regular 1.0" 631 658 !- 632 n cid = ncdf_ids(pfileid)659 nfid = W_F(pfileid)%ncfid 633 660 !- 634 661 ndim = 2 635 dims(1:2) = (/ xid(pfileid),yid(pfileid)/)662 dims(1:2) = (/ W_F(pfileid)%xid,W_F(pfileid)%yid /) 636 663 !- 637 664 tmp_name = phname 638 665 IF (rectilinear) THEN 639 IF ( nb_hax(pfileid)== 0) THEN666 IF (W_F(pfileid)%n_hax == 0) THEN 640 667 lon_name = 'lon' 641 668 lat_name = 'lat' … … 645 672 ENDIF 646 673 ELSE 647 IF ( nb_hax(pfileid)== 0) THEN674 IF (W_F(pfileid)%n_hax == 0) THEN 648 675 lon_name = 'nav_lon' 649 676 lat_name = 'nav_lat' … … 656 683 ! 1.2 Save the informations 657 684 !- 658 phid = nb_hax(pfileid)+1 659 nb_hax(pfileid) = phid 660 !- 661 hax_name(pfileid,phid,1:2) = (/ lon_name,lat_name /) 685 phid = W_F(pfileid)%n_hax+1 686 W_F(pfileid)%n_hax = phid 687 W_F(pfileid)%hax_name(phid,1:2) = (/ lon_name,lat_name /) 662 688 tmp_title = phtitle 663 689 !- … … 668 694 IF (rectilinear) THEN 669 695 ndim = 1 670 dims(1:1) = (/ xid(pfileid)/)671 ENDIF 672 iret = NF90_DEF_VAR (n cid,lon_name,NF90_FLOAT,dims(1:ndim),nlonid)696 dims(1:1) = (/ W_F(pfileid)%xid /) 697 ENDIF 698 iret = NF90_DEF_VAR (nfid,lon_name,NF90_FLOAT,dims(1:ndim),nlonid) 673 699 IF (rectilinear) THEN 674 iret = NF90_PUT_ATT (n cid,nlonid,'axis',"X")675 ENDIF 676 iret = NF90_PUT_ATT (n cid,nlonid,'standard_name',"longitude")677 iret = NF90_PUT_ATT (n cid,nlonid,'units',"degrees_east")678 iret = NF90_PUT_ATT (n cid,nlonid,'valid_min', &700 iret = NF90_PUT_ATT (nfid,nlonid,'axis',"X") 701 ENDIF 702 iret = NF90_PUT_ATT (nfid,nlonid,'standard_name',"longitude") 703 iret = NF90_PUT_ATT (nfid,nlonid,'units',"degrees_east") 704 iret = NF90_PUT_ATT (nfid,nlonid,'valid_min', & 679 705 & REAL(MINVAL(plon),KIND=4)) 680 iret = NF90_PUT_ATT (n cid,nlonid,'valid_max', &706 iret = NF90_PUT_ATT (nfid,nlonid,'valid_max', & 681 707 & REAL(MAXVAL(plon),KIND=4)) 682 iret = NF90_PUT_ATT (n cid,nlonid,'long_name',"Longitude")683 iret = NF90_PUT_ATT (n cid,nlonid,'nav_model',TRIM(tmp_title))708 iret = NF90_PUT_ATT (nfid,nlonid,'long_name',"Longitude") 709 iret = NF90_PUT_ATT (nfid,nlonid,'nav_model',TRIM(tmp_title)) 684 710 !- 685 711 ! 3.0 Latitude … … 689 715 IF (rectilinear) THEN 690 716 ndim = 1 691 dims(1:1) = (/ yid(pfileid)/)692 ENDIF 693 iret = NF90_DEF_VAR (n cid,lat_name,NF90_FLOAT,dims(1:ndim),nlatid)717 dims(1:1) = (/ W_F(pfileid)%yid /) 718 ENDIF 719 iret = NF90_DEF_VAR (nfid,lat_name,NF90_FLOAT,dims(1:ndim),nlatid) 694 720 IF (rectilinear) THEN 695 iret = NF90_PUT_ATT (n cid,nlatid,'axis',"Y")696 ENDIF 697 iret = NF90_PUT_ATT (n cid,nlatid,'standard_name',"latitude")698 iret = NF90_PUT_ATT (n cid,nlatid,'units',"degrees_north")699 iret = NF90_PUT_ATT (n cid,nlatid,'valid_min', &721 iret = NF90_PUT_ATT (nfid,nlatid,'axis',"Y") 722 ENDIF 723 iret = NF90_PUT_ATT (nfid,nlatid,'standard_name',"latitude") 724 iret = NF90_PUT_ATT (nfid,nlatid,'units',"degrees_north") 725 iret = NF90_PUT_ATT (nfid,nlatid,'valid_min', & 700 726 & REAL(MINVAL(plat),KIND=4)) 701 iret = NF90_PUT_ATT (n cid,nlatid,'valid_max', &727 iret = NF90_PUT_ATT (nfid,nlatid,'valid_max', & 702 728 & REAL(MAXVAL(plat),KIND=4)) 703 iret = NF90_PUT_ATT (n cid,nlatid,'long_name',"Latitude")704 iret = NF90_PUT_ATT (n cid,nlatid,'nav_model',TRIM(tmp_title))705 !- 706 iret = NF90_ENDDEF (n cid)729 iret = NF90_PUT_ATT (nfid,nlatid,'long_name',"Latitude") 730 iret = NF90_PUT_ATT (nfid,nlatid,'nav_model',TRIM(tmp_title)) 731 !- 732 iret = NF90_ENDDEF (nfid) 707 733 !- 708 734 ! 4.0 storing the geographical coordinates … … 710 736 IF (l_dbg) WRITE(*,*) "histhori_regular 4.0" 711 737 !- 712 orix = slab_ori(pfileid,1)713 oriy = slab_ori(pfileid,2)714 par_szx = slab_sz(pfileid,1)715 par_szy = slab_sz(pfileid,2)738 orix = W_F(pfileid)%slab_ori(1) 739 oriy = W_F(pfileid)%slab_ori(2) 740 par_szx = W_F(pfileid)%slab_sz(1) 741 par_szy = W_F(pfileid)%slab_sz(2) 716 742 !- 717 743 ! Transfer the longitude 718 744 !- 719 745 IF (rectilinear) THEN 720 iret = NF90_PUT_VAR (n cid,nlonid,plon(orix:orix+par_szx-1,1))721 ELSE 722 iret = NF90_PUT_VAR (n cid,nlonid, &746 iret = NF90_PUT_VAR (nfid,nlonid,plon(orix:orix+par_szx-1,1)) 747 ELSE 748 iret = NF90_PUT_VAR (nfid,nlonid, & 723 749 & plon(orix:orix+par_szx-1,oriy:oriy+par_szy-1)) 724 750 ENDIF … … 727 753 !- 728 754 IF (rectilinear) THEN 729 iret = NF90_PUT_VAR (n cid,nlatid,plat(1,oriy:oriy+par_szy-1))730 ELSE 731 iret = NF90_PUT_VAR (n cid,nlatid, &755 iret = NF90_PUT_VAR (nfid,nlatid,plat(1,oriy:oriy+par_szy-1)) 756 ELSE 757 iret = NF90_PUT_VAR (nfid,nlatid, & 732 758 & plat(orix:orix+par_szx-1,oriy:oriy+par_szy-1)) 733 759 ENDIF 734 760 !- 735 iret = NF90_REDEF (n cid)761 iret = NF90_REDEF (nfid) 736 762 !------------------------------ 737 763 END SUBROUTINE histhori_regular … … 779 805 INTEGER :: nbbounds 780 806 INTEGER :: nlonid,nlatid,nlonidb,nlatidb 781 INTEGER :: iret,n cid,twoid807 INTEGER :: iret,nfid,twoid 782 808 LOGICAL :: transp = .FALSE. 783 809 REAL,ALLOCATABLE,DIMENSION(:,:) :: bounds_trans … … 788 814 ! 1.0 Check that all fits in the buffers 789 815 !- 790 IF ( (pim /= full_size(pfileid,1)) &791 & .OR.(full_size(pfileid,2) /= 1) ) THEN816 IF ( (pim /= W_F(pfileid)%full_size(1)) & 817 & .OR.(W_F(pfileid)%full_size(2) /= 1) ) THEN 792 818 CALL ipslerr (3,"histhori", & 793 &'The new horizontal grid does not have the same size', &794 &'as the one provided to histbeg. This is not yet ', &795 &'possible in the hist package.')819 & 'The new horizontal grid does not have the same size', & 820 & 'as the one provided to histbeg. This is not yet ', & 821 & 'possible in the hist package.') 796 822 ENDIF 797 823 !- … … 800 826 IF (l_dbg) WRITE(*,*) 'histhori_irregular 1.0' 801 827 !- 802 n cid = ncdf_ids(pfileid)828 nfid = W_F(pfileid)%ncfid 803 829 !- 804 830 IF (SIZE(plon_bounds,DIM=1) == pim) THEN … … 817 843 ALLOCATE(bounds_trans(nbbounds,pim)) 818 844 !- 819 iret = NF90_DEF_DIM (n cid,'nbnd',nbbounds,twoid)845 iret = NF90_DEF_DIM (nfid,'nbnd',nbbounds,twoid) 820 846 ndim = 1 821 dims(1) = xid(pfileid)847 dims(1) = W_F(pfileid)%xid 822 848 ndimb = 2 823 dimsb(1:2) = (/ twoid, xid(pfileid)/)849 dimsb(1:2) = (/ twoid,W_F(pfileid)%xid /) 824 850 !- 825 851 tmp_name = phname 826 IF ( nb_hax(pfileid)== 0) THEN852 IF (W_F(pfileid)%n_hax == 0) THEN 827 853 lon_name = 'nav_lon' 828 854 lat_name = 'nav_lat' … … 836 862 ! 1.2 Save the informations 837 863 !- 838 phid = nb_hax(pfileid)+1 839 nb_hax(pfileid) = phid 840 !- 841 hax_name(pfileid,phid,1:2) = (/ lon_name,lat_name /) 864 phid = W_F(pfileid)%n_hax+1 865 W_F(pfileid)%n_hax = phid 866 W_F(pfileid)%hax_name(phid,1:2) = (/ lon_name,lat_name /) 842 867 tmp_title = phtitle 843 868 !- … … 846 871 IF (l_dbg) WRITE(*,*) "histhori_irregular 2.0" 847 872 !- 848 iret = NF90_DEF_VAR (n cid,lon_name,NF90_FLOAT,dims(1:ndim),nlonid)849 iret = NF90_PUT_ATT (n cid,nlonid,'standard_name',"longitude")850 iret = NF90_PUT_ATT (n cid,nlonid,'units',"degrees_east")851 iret = NF90_PUT_ATT (n cid,nlonid,'valid_min', &873 iret = NF90_DEF_VAR (nfid,lon_name,NF90_FLOAT,dims(1:ndim),nlonid) 874 iret = NF90_PUT_ATT (nfid,nlonid,'standard_name',"longitude") 875 iret = NF90_PUT_ATT (nfid,nlonid,'units',"degrees_east") 876 iret = NF90_PUT_ATT (nfid,nlonid,'valid_min', & 852 877 & REAL(MINVAL(plon),KIND=4)) 853 iret = NF90_PUT_ATT (n cid,nlonid,'valid_max', &878 iret = NF90_PUT_ATT (nfid,nlonid,'valid_max', & 854 879 & REAL(MAXVAL(plon),KIND=4)) 855 iret = NF90_PUT_ATT (n cid,nlonid,'long_name',"Longitude")856 iret = NF90_PUT_ATT (n cid,nlonid,'nav_model',TRIM(tmp_title))880 iret = NF90_PUT_ATT (nfid,nlonid,'long_name',"Longitude") 881 iret = NF90_PUT_ATT (nfid,nlonid,'nav_model',TRIM(tmp_title)) 857 882 !- 858 883 ! 2.1 Longitude bounds 859 884 !- 860 iret = NF90_PUT_ATT (n cid,nlonid,'bounds',TRIM(lonbound_name))861 iret = NF90_DEF_VAR (n cid,lonbound_name,NF90_FLOAT, &885 iret = NF90_PUT_ATT (nfid,nlonid,'bounds',TRIM(lonbound_name)) 886 iret = NF90_DEF_VAR (nfid,lonbound_name,NF90_FLOAT, & 862 887 & dimsb(1:ndimb),nlonidb) 863 888 longname = 'Boundaries for coordinate variable '//TRIM(lon_name) 864 iret = NF90_PUT_ATT (n cid,nlonidb,'long_name',TRIM(longname))889 iret = NF90_PUT_ATT (nfid,nlonidb,'long_name',TRIM(longname)) 865 890 !- 866 891 ! 3.0 Latitude … … 868 893 IF (l_dbg) WRITE(*,*) "histhori_irregular 3.0" 869 894 !- 870 iret = NF90_DEF_VAR (n cid,lat_name,NF90_FLOAT,dims(1:ndim),nlatid)871 iret = NF90_PUT_ATT (n cid,nlatid,'standard_name',"latitude")872 iret = NF90_PUT_ATT (n cid,nlatid,'units',"degrees_north")873 iret = NF90_PUT_ATT (n cid,nlatid,'valid_min', &895 iret = NF90_DEF_VAR (nfid,lat_name,NF90_FLOAT,dims(1:ndim),nlatid) 896 iret = NF90_PUT_ATT (nfid,nlatid,'standard_name',"latitude") 897 iret = NF90_PUT_ATT (nfid,nlatid,'units',"degrees_north") 898 iret = NF90_PUT_ATT (nfid,nlatid,'valid_min', & 874 899 & REAL(MINVAL(plat),KIND=4)) 875 iret = NF90_PUT_ATT (n cid,nlatid,'valid_max', &900 iret = NF90_PUT_ATT (nfid,nlatid,'valid_max', & 876 901 & REAL(MAXVAL(plat),KIND=4)) 877 iret = NF90_PUT_ATT (n cid,nlatid,'long_name',"Latitude")878 iret = NF90_PUT_ATT (n cid,nlatid,'nav_model',TRIM(tmp_title))902 iret = NF90_PUT_ATT (nfid,nlatid,'long_name',"Latitude") 903 iret = NF90_PUT_ATT (nfid,nlatid,'nav_model',TRIM(tmp_title)) 879 904 !- 880 905 ! 3.1 Latitude bounds 881 906 !- 882 iret = NF90_PUT_ATT (n cid,nlatid,'bounds',TRIM(latbound_name))883 iret = NF90_DEF_VAR (n cid,latbound_name,NF90_FLOAT, &907 iret = NF90_PUT_ATT (nfid,nlatid,'bounds',TRIM(latbound_name)) 908 iret = NF90_DEF_VAR (nfid,latbound_name,NF90_FLOAT, & 884 909 & dimsb(1:ndimb),nlatidb) 885 910 longname = 'Boundaries for coordinate variable '//TRIM(lat_name) 886 iret = NF90_PUT_ATT (n cid,nlatidb,'long_name',TRIM(longname))887 !- 888 iret = NF90_ENDDEF (n cid)911 iret = NF90_PUT_ATT (nfid,nlatidb,'long_name',TRIM(longname)) 912 !- 913 iret = NF90_ENDDEF (nfid) 889 914 !- 890 915 ! 4.0 storing the geographical coordinates … … 894 919 ! 4.1 Write the longitude 895 920 !- 896 iret = NF90_PUT_VAR (n cid,nlonid,plon(1:pim))921 iret = NF90_PUT_VAR (nfid,nlonid,plon(1:pim)) 897 922 !- 898 923 ! 4.2 Write the longitude bounds … … 903 928 bounds_trans = plon_bounds 904 929 ENDIF 905 iret = NF90_PUT_VAR (n cid,nlonidb,bounds_trans(1:nbbounds,1:pim))930 iret = NF90_PUT_VAR (nfid,nlonidb,bounds_trans(1:nbbounds,1:pim)) 906 931 !- 907 932 ! 4.3 Write the latitude 908 933 !- 909 iret = NF90_PUT_VAR (n cid,nlatid,plat(1:pim))934 iret = NF90_PUT_VAR (nfid,nlatid,plat(1:pim)) 910 935 !- 911 936 ! 4.4 Write the latitude bounds … … 916 941 bounds_trans = plat_bounds 917 942 ENDIF 918 iret = NF90_PUT_VAR (n cid,nlatidb,bounds_trans(1:nbbounds,1:pim))943 iret = NF90_PUT_VAR (nfid,nlatidb,bounds_trans(1:nbbounds,1:pim)) 919 944 !- 920 945 DEALLOCATE(bounds_trans) 921 946 !- 922 iret = NF90_REDEF (n cid)947 iret = NF90_REDEF (nfid) 923 948 !-------------------------------- 924 949 END SUBROUTINE histhori_irregular … … 963 988 CHARACTER(LEN=80) :: str80 964 989 CHARACTER(LEN=20) :: direction 965 INTEGER :: iret,leng,n cid990 INTEGER :: iret,leng,nfid 966 991 LOGICAL :: l_dbg 967 992 !--------------------------------------------------------------------- … … 997 1022 ENDIF 998 1023 !- 999 IF ( nb_zax(pfileid)+1 > nb_zax_max) THEN1024 IF (W_F(pfileid)%n_zax+1 > nb_zax_max) THEN 1000 1025 CALL ipslerr (3,"histvert", & 1001 1026 & 'Table of vertical axes too small. You should increase ',& … … 1004 1029 ENDIF 1005 1030 !- 1006 iv = nb_zax(pfileid)1031 iv = W_F(pfileid)%n_zax 1007 1032 IF (iv > 1) THEN 1008 CALL find_str ( zax_name(pfileid,1:iv-1),pzaxname,pos)1033 CALL find_str (W_F(pfileid)%zax_name(1:iv-1),pzaxname,pos) 1009 1034 ELSE 1010 1035 pos = 0 … … 1019 1044 ENDIF 1020 1045 !- 1021 iv = nb_zax(pfileid)+11046 iv = W_F(pfileid)%n_zax+1 1022 1047 !- 1023 1048 ! 2.0 Add the information to the file … … 1026 1051 & WRITE(*,*) "histvert : 2.0 Add the information to the file" 1027 1052 !- 1028 n cid = ncdf_ids(pfileid)1053 nfid = W_F(pfileid)%ncfid 1029 1054 !- 1030 1055 leng = MIN(LEN_TRIM(pzaxname),20) 1031 iret = NF90_DEF_DIM (n cid,pzaxname(1:leng),pzsize,zaxid_tmp)1032 iret = NF90_DEF_VAR (n cid,pzaxname(1:leng),NF90_FLOAT, &1056 iret = NF90_DEF_DIM (nfid,pzaxname(1:leng),pzsize,zaxid_tmp) 1057 iret = NF90_DEF_VAR (nfid,pzaxname(1:leng),NF90_FLOAT, & 1033 1058 & zaxid_tmp,zdimid) 1034 iret = NF90_PUT_ATT (n cid,zdimid,'axis',"Z")1035 iret = NF90_PUT_ATT (n cid,zdimid,'standard_name',"model_level_number")1059 iret = NF90_PUT_ATT (nfid,zdimid,'axis',"Z") 1060 iret = NF90_PUT_ATT (nfid,zdimid,'standard_name',"model_level_number") 1036 1061 leng = MIN(LEN_TRIM(pzaxunit),20) 1037 1062 IF (leng > 0) THEN 1038 iret = NF90_PUT_ATT (n cid,zdimid,'units',pzaxunit(1:leng))1039 ENDIF 1040 iret = NF90_PUT_ATT (n cid,zdimid,'positive',TRIM(direction))1041 iret = NF90_PUT_ATT (n cid,zdimid,'valid_min', &1063 iret = NF90_PUT_ATT (nfid,zdimid,'units',pzaxunit(1:leng)) 1064 ENDIF 1065 iret = NF90_PUT_ATT (nfid,zdimid,'positive',TRIM(direction)) 1066 iret = NF90_PUT_ATT (nfid,zdimid,'valid_min', & 1042 1067 & REAL(MINVAL(pzvalues(1:pzsize)),KIND=4)) 1043 iret = NF90_PUT_ATT (n cid,zdimid,'valid_max', &1068 iret = NF90_PUT_ATT (nfid,zdimid,'valid_max', & 1044 1069 & REAL(MAXVAL(pzvalues(1:pzsize)),KIND=4)) 1045 1070 leng = MIN(LEN_TRIM(pzaxname),20) 1046 iret = NF90_PUT_ATT (n cid,zdimid,'title',pzaxname(1:leng))1071 iret = NF90_PUT_ATT (nfid,zdimid,'title',pzaxname(1:leng)) 1047 1072 leng = MIN(LEN_TRIM(pzaxtitle),80) 1048 iret = NF90_PUT_ATT (n cid,zdimid,'long_name',pzaxtitle(1:leng))1049 !- 1050 iret = NF90_ENDDEF (n cid)1051 !- 1052 iret = NF90_PUT_VAR (n cid,zdimid,pzvalues(1:pzsize))1053 !- 1054 iret = NF90_REDEF (n cid)1073 iret = NF90_PUT_ATT (nfid,zdimid,'long_name',pzaxtitle(1:leng)) 1074 !- 1075 iret = NF90_ENDDEF (nfid) 1076 !- 1077 iret = NF90_PUT_VAR (nfid,zdimid,pzvalues(1:pzsize)) 1078 !- 1079 iret = NF90_REDEF (nfid) 1055 1080 !- 1056 1081 !- 3.0 add the information to the common … … 1059 1084 & WRITE(*,*) "histvert : 3.0 add the information to the common" 1060 1085 !- 1061 nb_zax(pfileid)= iv1062 zax_size(pfileid,iv) = pzsize1063 zax_name(pfileid,iv) = pzaxname1064 zax_ids(pfileid,iv) = zaxid_tmp1065 pzaxid = 1086 W_F(pfileid)%n_zax = iv 1087 W_F(pfileid)%zax_size(iv) = pzsize 1088 W_F(pfileid)%zax_name(iv) = pzaxname 1089 W_F(pfileid)%zax_ids(iv) = zaxid_tmp 1090 pzaxid = iv 1066 1091 !---------------------- 1067 1092 END SUBROUTINE histvert … … 1143 1168 ex_topps = 'ave, inst, t_min, t_max, t_sum, once, never, l_max, l_min' 1144 1169 !- 1145 nb_var(pfileid) = nb_var(pfileid)+11146 iv = nb_var(pfileid)1170 W_F(pfileid)%n_var = W_F(pfileid)%n_var+1 1171 iv = W_F(pfileid)%n_var 1147 1172 !- 1148 1173 IF (iv > nb_var_max) THEN … … 1159 1184 !- 1160 1185 IF (iv > 1) THEN 1161 CALL find_str ( name(pfileid,1:iv-1),pvarname,pos)1186 CALL find_str (W_F(pfileid)%W_V(1:iv-1)%v_name,pvarname,pos) 1162 1187 ELSE 1163 1188 pos = 0 … … 1172 1197 ENDIF 1173 1198 !- 1174 name(pfileid,iv)= pvarname1175 title(pfileid,iv)= ptitle1176 unit_name(pfileid,iv)= punit1177 tmp_name = name(pfileid,iv)1199 W_F(pfileid)%W_V(iv)%v_name = pvarname 1200 W_F(pfileid)%W_V(iv)%title = ptitle 1201 W_F(pfileid)%W_V(iv)%unit_name = punit 1202 tmp_name = W_F(pfileid)%W_V(iv)%v_name 1178 1203 !- 1179 1204 ! 1.1 decode the operations 1180 1205 !- 1181 fullop(pfileid,iv)= popp1206 W_F(pfileid)%W_V(iv)%fullop = popp 1182 1207 tmp_str80 = popp 1183 1208 CALL buildop & 1184 1209 & (tmp_str80,ex_topps,tmp_topp,nbopp_max,missing_val, & 1185 & tmp_sopp,tmp_scal, nbopp(pfileid,iv))1186 !- 1187 topp(pfileid,iv)= tmp_topp1188 DO i=1, nbopp(pfileid,iv)1189 sopps(pfileid,iv,i) = tmp_sopp(i)1190 scal(pfileid,iv,i) = tmp_scal(i)1210 & tmp_sopp,tmp_scal,W_F(pfileid)%W_V(iv)%nbopp) 1211 !- 1212 W_F(pfileid)%W_V(iv)%topp = tmp_topp 1213 DO i=1,W_F(pfileid)%W_V(iv)%nbopp 1214 W_F(pfileid)%W_V(iv)%sopps(i) = tmp_sopp(i) 1215 W_F(pfileid)%W_V(iv)%scal(i) = tmp_scal(i) 1191 1216 ENDDO 1192 1217 !- … … 1194 1219 ! then we need to add identity 1195 1220 !- 1196 IF (2*INT(nbopp(pfileid,iv)/2.0) == nbopp(pfileid,iv)) THEN 1197 nbopp(pfileid,iv) = nbopp(pfileid,iv)+1 1198 sopps(pfileid,iv,nbopp(pfileid,iv)) = 'ident' 1199 scal(pfileid,iv,nbopp(pfileid,iv)) = missing_val 1221 IF ( 2*INT(W_F(pfileid)%W_V(iv)%nbopp/2.0) & 1222 & == W_F(pfileid)%W_V(iv)%nbopp) THEN 1223 W_F(pfileid)%W_V(iv)%nbopp = W_F(pfileid)%W_V(iv)%nbopp+1 1224 W_F(pfileid)%W_V(iv)%sopps(W_F(pfileid)%W_V(iv)%nbopp) = 'ident' 1225 W_F(pfileid)%W_V(iv)%scal(W_F(pfileid)%W_V(iv)%nbopp) = missing_val 1200 1226 ENDIF 1201 1227 !- … … 1203 1229 !- 1204 1230 IF (pnbbyt == hist_r8) THEN 1205 v_typ(pfileid,iv)= hist_r81206 ELSE 1207 v_typ(pfileid,iv)= hist_r41231 W_F(pfileid)%W_V(iv)%v_typ = hist_r8 1232 ELSE 1233 W_F(pfileid)%W_V(iv)%v_typ = hist_r4 1208 1234 ENDIF 1209 1235 !- 1210 1236 ! 2.0 Put the size of the variable in the common and check 1211 1237 !- 1212 IF (l_dbg) & 1213 & WRITE(*,*) "histdef : 2.0",pfileid,iv,nbopp(pfileid,iv), & 1214 & sopps(pfileid,iv,1:nbopp(pfileid,iv)), & 1215 & scal(pfileid,iv,1:nbopp(pfileid,iv)) 1216 !- 1217 scsize(pfileid,iv,1:3) = (/ pxsize,pysize,pzsize /) 1218 !- 1219 zorig(pfileid,iv,1:3) = & 1220 & (/ slab_ori(pfileid,1),slab_ori(pfileid,2),par_oriz /) 1221 !- 1222 zsize(pfileid,iv,1:3) = & 1223 & (/ slab_sz(pfileid,1),slab_sz(pfileid,2),par_szz /) 1224 !- 1225 ! Is the size of the full array the same as that of the coordinates ? 1226 !- 1227 IF ( (pxsize > full_size(pfileid,1)) & 1228 & .OR.(pysize > full_size(pfileid,2)) ) THEN 1238 IF (l_dbg) THEN 1239 WRITE(*,*) "histdef : 2.0",pfileid,iv,W_F(pfileid)%W_V(iv)%nbopp, & 1240 & W_F(pfileid)%W_V(iv)%sopps(1:W_F(pfileid)%W_V(iv)%nbopp), & 1241 & W_F(pfileid)%W_V(iv)%scal(1:W_F(pfileid)%W_V(iv)%nbopp) 1242 ENDIF 1243 !- 1244 W_F(pfileid)%W_V(iv)%scsize(1:3) = (/ pxsize,pysize,pzsize /) 1245 W_F(pfileid)%W_V(iv)%zorig(1:3) = & 1246 & (/ W_F(pfileid)%slab_ori(1),W_F(pfileid)%slab_ori(2),par_oriz /) 1247 W_F(pfileid)%W_V(iv)%zsize(1:3) = & 1248 & (/ W_F(pfileid)%slab_sz(1),W_F(pfileid)%slab_sz(2),par_szz /) 1249 !- 1250 ! Is the size of the full array the same as that of the coordinates ? 1251 !- 1252 IF ( (pxsize > W_F(pfileid)%full_size(1)) & 1253 & .OR.(pysize > W_F(pfileid)%full_size(2)) ) THEN 1229 1254 !- 1230 1255 str70 = "The size of the variable is different "// & 1231 1256 & "from the one of the coordinates" 1232 1257 WRITE(str71,'("Size of coordinates :",2I4)') & 1233 & full_size(pfileid,1),full_size(pfileid,2)1258 & W_F(pfileid)%full_size(1),W_F(pfileid)%full_size(2) 1234 1259 WRITE(str72,'("Size declared for variable ",a," :",2I4)') & 1235 1260 & TRIM(tmp_name),pxsize,pysize … … 1237 1262 ENDIF 1238 1263 !- 1239 ! Is the size of the zoom smal er than the coordinates ?1240 !- 1241 IF ( ( full_size(pfileid,1) < slab_sz(pfileid,1)) &1242 & .OR.( full_size(pfileid,2) < slab_sz(pfileid,2)) ) THEN1264 ! Is the size of the zoom smaller than the coordinates ? 1265 !- 1266 IF ( (W_F(pfileid)%full_size(1) < W_F(pfileid)%slab_sz(1)) & 1267 & .OR.(W_F(pfileid)%full_size(2) < W_F(pfileid)%slab_sz(2)) ) THEN 1243 1268 str70 = & 1244 1269 & "Size of variable should be greater or equal to those of the zoom" 1245 1270 WRITE(str71,'("Size of XY zoom :",2I4)') & 1246 & slab_sz(pfileid,1),slab_sz(pfileid,1)1247 WRITE(str72,'("Size declared for variable ", a," :",2I4)') &1271 & W_F(pfileid)%slab_sz(1),W_F(pfileid)%slab_sz(2) 1272 WRITE(str72,'("Size declared for variable ",A," :",2I4)') & 1248 1273 & TRIM(tmp_name),pxsize,pysize 1249 1274 CALL ipslerr (3,"histdef",str70,str71,str72) … … 1253 1278 ! and a fall back onto the default grid 1254 1279 !- 1255 IF ( (phoriid > 0).AND.(phoriid <= nb_hax(pfileid)) ) THEN1256 var_haxid(pfileid,iv)= phoriid1257 ELSE 1258 var_haxid(pfileid,iv)= 11280 IF ( (phoriid > 0).AND.(phoriid <= W_F(pfileid)%n_hax) ) THEN 1281 W_F(pfileid)%W_V(iv)%h_axid = phoriid 1282 ELSE 1283 W_F(pfileid)%W_V(iv)%h_axid = 1 1259 1284 CALL ipslerr (2,"histdef", & 1260 1285 & 'We use the default grid for variable as an invalide',& … … 1268 1293 !-- Does the vertical coordinate exist ? 1269 1294 !- 1270 IF (pzid > nb_zax(pfileid)) THEN1295 IF (pzid > W_F(pfileid)%n_zax) THEN 1271 1296 WRITE(str70, & 1272 1297 & '("The vertical coordinate chosen for variable ",a)') & … … 1278 1303 !-- Is the vertical size of the variable equal to that of the axis ? 1279 1304 !- 1280 IF (par_szz /= zax_size(pfileid,pzid)) THEN1305 IF (par_szz /= W_F(pfileid)%zax_size(pzid)) THEN 1281 1306 str70 = "The size of the zoom does not correspond "// & 1282 1307 & "to the size of the chosen vertical axis" 1283 1308 WRITE(str71,'("Size of zoom in z :",I4)') par_szz 1284 1309 WRITE(str72,'("Size declared for axis ",A," :",I4)') & 1285 & TRIM( zax_name(pfileid,pzid)),zax_size(pfileid,pzid)1310 & TRIM(W_F(pfileid)%zax_name(pzid)),W_F(pfileid)%zax_size(pzid) 1286 1311 CALL ipslerr (3,"histdef",str70,str71,str72) 1287 1312 ENDIF 1288 1313 !- 1289 !-- Is the zoom smal er that the total size of the variable ?1314 !-- Is the zoom smaller that the total size of the variable ? 1290 1315 !- 1291 1316 IF (pzsize < par_szz) THEN … … 1297 1322 CALL ipslerr (3,"histdef",str70,str71,str72) 1298 1323 ENDIF 1299 var_zaxid(pfileid,iv)= pzid1300 ELSE 1301 var_zaxid(pfileid,iv)= -991324 W_F(pfileid)%W_V(iv)%z_axid = pzid 1325 ELSE 1326 W_F(pfileid)%W_V(iv)%z_axid = -99 1302 1327 ENDIF 1303 1328 !- … … 1310 1335 ! that they fit into the tmp_buffer 1311 1336 !- 1312 buff_sz = zsize(pfileid,iv,1)*zsize(pfileid,iv,2)*zsize(pfileid,iv,3) 1337 buff_sz = W_F(pfileid)%W_V(iv)%zsize(1) & 1338 & *W_F(pfileid)%W_V(iv)%zsize(2) & 1339 & *W_F(pfileid)%W_V(iv)%zsize(3) 1313 1340 !- 1314 1341 ! 3.2 move the pointer of the buffer array for operation … … 1318 1345 & .AND.(TRIM(tmp_topp) /= "once") & 1319 1346 & .AND.(TRIM(tmp_topp) /= "never") )THEN 1320 point(pfileid,iv)= buff_pos+11347 W_F(pfileid)%W_V(iv)%point = buff_pos+1 1321 1348 buff_pos = buff_pos+buff_sz 1322 1349 IF (l_dbg) THEN 1323 1350 WRITE(*,*) "histdef : 3.2 bufpos for iv = ",iv, & 1324 & " pfileid = ",pfileid," is = ",point(pfileid,iv)1351 & " pfileid = ",pfileid," is = ",W_F(pfileid)%W_V(iv)%point 1325 1352 ENDIF 1326 1353 ENDIF … … 1333 1360 IF (l_dbg) WRITE(*,*) "histdef : 4.0" 1334 1361 !- 1335 freq_opp(pfileid,iv)= pfreq_opp1336 freq_wrt(pfileid,iv)= pfreq_wrt1362 W_F(pfileid)%W_V(iv)%freq_opp = pfreq_opp 1363 W_F(pfileid)%W_V(iv)%freq_wrt = pfreq_wrt 1337 1364 !- 1338 1365 CALL ioget_calendar(un_an,un_jour) … … 1352 1379 ! 4.1 Frequency of operations and output should be larger than deltat ! 1353 1380 !- 1354 IF (test_fopp < deltat(pfileid)) THEN1381 IF (test_fopp < W_F(pfileid)%deltat) THEN 1355 1382 str70 = 'Frequency of operations should be larger than deltat' 1356 1383 WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') & … … 1360 1387 CALL ipslerr (2,"histdef",str70,str71,str72) 1361 1388 !- 1362 freq_opp(pfileid,iv) = deltat(pfileid)1363 ENDIF 1364 !- 1365 IF (test_fwrt < deltat(pfileid)) THEN1389 W_F(pfileid)%W_V(iv)%freq_opp = W_F(pfileid)%deltat 1390 ENDIF 1391 !- 1392 IF (test_fwrt < W_F(pfileid)%deltat) THEN 1366 1393 str70 = 'Frequency of output should be larger than deltat' 1367 1394 WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') & … … 1371 1398 CALL ipslerr (2,"histdef",str70,str71,str72) 1372 1399 !- 1373 freq_wrt(pfileid,iv) = deltat(pfileid)1400 W_F(pfileid)%W_V(iv)%freq_wrt = W_F(pfileid)%deltat 1374 1401 ENDIF 1375 1402 !- … … 1387 1414 CALL ipslerr (2,"histdef",str70,str71,str72) 1388 1415 IF (test_fopp < test_fwrt) THEN 1389 freq_opp(pfileid,iv)= pfreq_opp1390 freq_wrt(pfileid,iv)= pfreq_opp1416 W_F(pfileid)%W_V(iv)%freq_opp = pfreq_opp 1417 W_F(pfileid)%W_V(iv)%freq_wrt = pfreq_opp 1391 1418 ELSE 1392 freq_opp(pfileid,iv)= pfreq_wrt1393 freq_wrt(pfileid,iv)= pfreq_wrt1419 W_F(pfileid)%W_V(iv)%freq_opp = pfreq_wrt 1420 W_F(pfileid)%W_V(iv)%freq_wrt = pfreq_wrt 1394 1421 ENDIF 1395 1422 ENDIF … … 1403 1430 str72 = 'PATCH : The output frequency is used for both' 1404 1431 CALL ipslerr (2,"histdef",str70,str71,str72) 1405 freq_opp(pfileid,iv)= pfreq_wrt1432 W_F(pfileid)%W_V(iv)%freq_opp = pfreq_wrt 1406 1433 ENDIF 1407 1434 ELSE … … 1417 1444 IF (l_dbg) WRITE(*,*) "histdef : 5.0" 1418 1445 !- 1419 hist_wrt_rng(pfileid,iv)= (PRESENT(var_range))1420 IF ( hist_wrt_rng(pfileid,iv)) THEN1421 hist_calc_rng(pfileid,iv)= (var_range(1) > var_range(2))1422 IF ( hist_calc_rng(pfileid,iv)) THEN1423 hist_minmax(pfileid,iv,1:2) = &1446 W_F(pfileid)%W_V(iv)%hist_wrt_rng = (PRESENT(var_range)) 1447 IF (W_F(pfileid)%W_V(iv)%hist_wrt_rng) THEN 1448 W_F(pfileid)%W_V(iv)%hist_calc_rng = (var_range(1) > var_range(2)) 1449 IF (W_F(pfileid)%W_V(iv)%hist_calc_rng) THEN 1450 W_F(pfileid)%W_V(iv)%hist_minmax(1:2) = & 1424 1451 & (/ ABS(missing_val),-ABS(missing_val) /) 1425 1452 ELSE 1426 hist_minmax(pfileid,iv,1:2) = var_range(1:2)1453 W_F(pfileid)%W_V(iv)%hist_minmax(1:2) = var_range(1:2) 1427 1454 ENDIF 1428 1455 ENDIF 1429 1456 !- 1430 1457 ! - freq_opp(pfileid,iv)/2./deltat(pfileid) 1431 last_opp(pfileid,iv) = itau0(pfileid)1458 W_F(pfileid)%W_V(iv)%last_opp = W_F(pfileid)%itau0 1432 1459 ! - freq_wrt(pfileid,iv)/2./deltat(pfileid) 1433 last_wrt(pfileid,iv) = itau0(pfileid)1460 W_F(pfileid)%W_V(iv)%last_wrt = W_F(pfileid)%itau0 1434 1461 ! - freq_opp(pfileid,iv)/2./deltat(pfileid) 1435 last_opp_chk(pfileid,iv) = itau0(pfileid)1462 W_F(pfileid)%W_V(iv)%last_opp_chk = W_F(pfileid)%itau0 1436 1463 ! - freq_wrt(pfileid,iv)/2./deltat(pfileid) 1437 last_wrt_chk(pfileid,iv) = itau0(pfileid)1438 nb_opp(pfileid,iv)= 01439 nb_wrt(pfileid,iv)= 01464 W_F(pfileid)%W_V(iv)%last_wrt_chk = W_F(pfileid)%itau0 1465 W_F(pfileid)%W_V(iv)%nb_opp = 0 1466 W_F(pfileid)%W_V(iv)%nb_wrt = 0 1440 1467 !- 1441 1468 ! 6.0 Get the time axis for this variable … … 1443 1470 IF (l_dbg) WRITE(*,*) "histdef : 6.0" 1444 1471 !- 1445 IF ( freq_wrt(pfileid,iv)> 0) THEN1446 WRITE(str10,'(I8.8)') INT( freq_wrt(pfileid,iv))1472 IF (W_F(pfileid)%W_V(iv)%freq_wrt > 0) THEN 1473 WRITE(str10,'(I8.8)') INT(W_F(pfileid)%W_V(iv)%freq_wrt) 1447 1474 str40 = TRIM(tmp_topp)//"_"//TRIM(str10) 1448 1475 ELSE 1449 WRITE(str10,'(I2.2,"month")') ABS(INT( freq_wrt(pfileid,iv)))1476 WRITE(str10,'(I2.2,"month")') ABS(INT(W_F(pfileid)%W_V(iv)%freq_wrt)) 1450 1477 str40 = TRIM(tmp_topp)//"_"//TRIM(str10) 1451 1478 ENDIF 1452 CALL find_str ( tax_name(pfileid,1:nb_tax(pfileid)),str40,pos)1479 CALL find_str (W_F(pfileid)%W_V(1:W_F(pfileid)%n_tax)%tax_name,str40,pos) 1453 1480 !- 1454 1481 ! No time axis for once, l_max, l_min or never operation … … 1459 1486 & .AND.(TRIM(tmp_topp) /= 'l_min') ) THEN 1460 1487 IF (pos < 0) THEN 1461 nb_tax(pfileid) = nb_tax(pfileid)+11462 tax_name(pfileid,nb_tax(pfileid))= str401463 tax_last(pfileid,nb_tax(pfileid))= 01464 var_axid(pfileid,iv) = nb_tax(pfileid)1488 W_F(pfileid)%n_tax = W_F(pfileid)%n_tax+1 1489 W_F(pfileid)%W_V(W_F(pfileid)%n_tax)%tax_name = str40 1490 W_F(pfileid)%W_V(W_F(pfileid)%n_tax)%tax_last = 0 1491 W_F(pfileid)%W_V(iv)%t_axid = W_F(pfileid)%n_tax 1465 1492 ELSE 1466 var_axid(pfileid,iv)= pos1493 W_F(pfileid)%W_V(iv)%t_axid = pos 1467 1494 ENDIF 1468 1495 ELSE 1469 1496 IF (l_dbg) WRITE(*,*) "histdef : 7.0 ",TRIM(tmp_topp),'----' 1470 var_axid(pfileid,iv)= -991497 W_F(pfileid)%W_V(iv)%t_axid = -99 1471 1498 ENDIF 1472 1499 !- … … 1476 1503 IF ( (TRIM(tmp_topp) == 'once') & 1477 1504 & .OR.(TRIM(tmp_topp) == 'never') ) THEN 1478 freq_opp(pfileid,iv)= 0.1479 freq_wrt(pfileid,iv)= 0.1505 W_F(pfileid)%W_V(iv)%freq_opp = 0. 1506 W_F(pfileid)%W_V(iv)%freq_wrt = 0. 1480 1507 ENDIF 1481 1508 !--------------------- … … 1498 1525 INTEGER,INTENT(IN) :: pfileid 1499 1526 !- 1500 INTEGER :: n cid,ncvarid,iret,ndim,iv,itx,ziv,itax,dim_cnt1527 INTEGER :: nfid,nvid,iret,ndim,iv,itx,ziv,itax,dim_cnt 1501 1528 INTEGER,DIMENSION(4) :: dims 1502 1529 INTEGER :: year,month,day,hours,minutes … … 1514 1541 CALL ipsldbg (old_status=l_dbg) 1515 1542 !- 1516 n cid = ncdf_ids(pfileid)1543 nfid = W_F(pfileid)%ncfid 1517 1544 !- 1518 1545 ! 1.0 Create the time axes … … 1520 1547 IF (l_dbg) WRITE(*,*) "histend : 1.0" 1521 1548 !--- 1522 iret = NF90_DEF_DIM (ncid,'time_counter',NF90_UNLIMITED,tid(pfileid)) 1549 iret = NF90_DEF_DIM (nfid,'time_counter', & 1550 & NF90_UNLIMITED,W_F(pfileid)%tid) 1523 1551 !- 1524 1552 ! 1.1 Define all the time axes needed for this file 1525 1553 !- 1526 DO itx=1, nb_tax(pfileid)1527 dims(1) = tid(pfileid)1528 IF ( nb_tax(pfileid)> 1) THEN1529 str30 = "t_"// tax_name(pfileid,itx)1554 DO itx=1,W_F(pfileid)%n_tax 1555 dims(1) = W_F(pfileid)%tid 1556 IF (W_F(pfileid)%n_tax > 1) THEN 1557 str30 = "t_"//W_F(pfileid)%W_V(itx)%tax_name 1530 1558 ELSE 1531 1559 str30 = "time_counter" 1532 1560 ENDIF 1533 iret = NF90_DEF_VAR (ncid,str30,NF90_DOUBLE, & 1534 & dims(1),tdimid(pfileid,itx)) 1535 IF (nb_tax(pfileid) <= 1) THEN 1536 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx),'axis',"T") 1537 ENDIF 1538 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx),'standard_name',"time") 1561 iret = NF90_DEF_VAR (nfid,str30,NF90_DOUBLE, & 1562 & dims(1),W_F(pfileid)%W_V(itx)%tdimid) 1563 IF (W_F(pfileid)%n_tax <= 1) THEN 1564 iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid,'axis',"T") 1565 ENDIF 1566 iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid, & 1567 & 'standard_name',"time") 1539 1568 !--- 1540 1569 ! To transform the current itau into a real date and take it … … 1545 1574 !--- 1546 1575 !-- rtime0 = itau2date(itau0(pfileid),date0(pfileid),deltat(pfileid)) 1547 rtime0 = date0(pfileid)1576 rtime0 = W_F(pfileid)%date0 1548 1577 !- 1549 1578 CALL ju2ymds(rtime0,year,month,day,sec) … … 1562 1591 & FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & 1563 1592 & 'seconds since ',year,month,day,hours,minutes,INT(sec) 1564 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx),'units',TRIM(str70)) 1593 iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid, & 1594 & 'units',TRIM(str70)) 1565 1595 !- 1566 1596 CALL ioget_calendar (str30) 1567 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx), & 1568 & 'calendar',TRIM(str30)) 1569 !- 1570 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx),'title','Time') 1571 !- 1572 iret = NF90_PUT_ATT (ncid,tdimid(pfileid,itx), & 1573 & 'long_name','Time axis') 1597 iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid, & 1598 & 'calendar',TRIM(str30)) 1599 !- 1600 iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid, & 1601 & 'title','Time') 1602 !- 1603 iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid, & 1604 & 'long_name','Time axis') 1574 1605 !- 1575 1606 WRITE (UNIT=str70, & 1576 1607 & FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & 1577 1608 & year,cal(month),day,hours,minutes,INT(sec) 1578 iret = NF90_PUT_ATT (n cid,tdimid(pfileid,itx), &1579 & 1609 iret = NF90_PUT_ATT (nfid,W_F(pfileid)%W_V(itx)%tdimid, & 1610 & 'time_origin',TRIM(str70)) 1580 1611 ENDDO 1581 1612 !- … … 1584 1615 IF (l_dbg) WRITE(*,*) "histend : 2.0" 1585 1616 !- 1586 DO iv=1, nb_var(pfileid)1617 DO iv=1,W_F(pfileid)%n_var 1587 1618 !--- 1588 itax = var_axid(pfileid,iv)1619 itax = W_F(pfileid)%W_V(iv)%t_axid 1589 1620 !--- 1590 IF ( regular(pfileid)) THEN1591 dims(1:2) = (/ xid(pfileid),yid(pfileid)/)1621 IF (W_F(pfileid)%regular) THEN 1622 dims(1:2) = (/ W_F(pfileid)%xid,W_F(pfileid)%yid /) 1592 1623 dim_cnt = 2 1593 1624 ELSE 1594 dims(1) = xid(pfileid)1625 dims(1) = W_F(pfileid)%xid 1595 1626 dim_cnt = 1 1596 1627 ENDIF 1597 1628 !--- 1598 tmp_opp = topp(pfileid,iv)1599 ziv = var_zaxid(pfileid,iv)1629 tmp_opp = W_F(pfileid)%W_V(iv)%topp 1630 ziv = W_F(pfileid)%W_V(iv)%z_axid 1600 1631 !--- 1601 1632 ! 2.1 dimension of field … … 1607 1638 IF (ziv == -99) THEN 1608 1639 ndim = dim_cnt+1 1609 dims(dim_cnt+1:dim_cnt+2) = (/ tid(pfileid),0 /)1640 dims(dim_cnt+1:dim_cnt+2) = (/ W_F(pfileid)%tid,0 /) 1610 1641 ELSE 1611 1642 ndim = dim_cnt+2 1612 dims(dim_cnt+1:dim_cnt+2) = (/zax_ids(pfileid,ziv),tid(pfileid)/) 1643 dims(dim_cnt+1:dim_cnt+2) = & 1644 & (/ W_F(pfileid)%zax_ids(ziv),W_F(pfileid)%tid /) 1613 1645 ENDIF 1614 1646 ELSE … … 1618 1650 ELSE 1619 1651 ndim = dim_cnt+1 1620 dims(dim_cnt+1:dim_cnt+2) = (/ zax_ids(pfileid,ziv),0 /)1652 dims(dim_cnt+1:dim_cnt+2) = (/ W_F(pfileid)%zax_ids(ziv),0 /) 1621 1653 ENDIF 1622 1654 ENDIF 1623 1655 !- 1624 iret = NF90_DEF_VAR (n cid,TRIM(name(pfileid,iv)), &1625 & v_typ(pfileid,iv),dims(1:ABS(ndim)),ncvarid)1626 !- 1627 ncvar_ids(pfileid,iv) = ncvarid1628 !- 1629 IF (LEN_TRIM( unit_name(pfileid,iv)) > 0) THEN1630 iret = NF90_PUT_ATT (n cid,ncvarid,'units', &1631 & TRIM( unit_name(pfileid,iv)))1656 iret = NF90_DEF_VAR (nfid,TRIM(W_F(pfileid)%W_V(iv)%v_name), & 1657 & W_F(pfileid)%W_V(iv)%v_typ,dims(1:ABS(ndim)),nvid) 1658 !- 1659 W_F(pfileid)%W_V(iv)%ncvid = nvid 1660 !- 1661 IF (LEN_TRIM(W_F(pfileid)%W_V(iv)%unit_name) > 0) THEN 1662 iret = NF90_PUT_ATT (nfid,nvid,'units', & 1663 & TRIM(W_F(pfileid)%W_V(iv)%unit_name)) 1632 1664 ENDIF 1633 iret = NF90_PUT_ATT (n cid,ncvarid,'standard_name', &1634 & TRIM( title(pfileid,iv)))1635 !- 1636 iret = NF90_PUT_ATT (n cid,ncvarid,'_FillValue', &1665 iret = NF90_PUT_ATT (nfid,nvid,'standard_name', & 1666 & TRIM(W_F(pfileid)%W_V(iv)%title)) 1667 !- 1668 iret = NF90_PUT_ATT (nfid,nvid,'_FillValue', & 1637 1669 & REAL(missing_val,KIND=4)) 1638 IF ( hist_wrt_rng(pfileid,iv)) THEN1639 iret = NF90_PUT_ATT (n cid,ncvarid,'valid_min', &1640 & REAL(hist_minmax(pfileid,iv,1),KIND=4))1641 iret = NF90_PUT_ATT (n cid,ncvarid,'valid_max', &1642 & REAL(hist_minmax(pfileid,iv,2),KIND=4))1670 IF (W_F(pfileid)%W_V(iv)%hist_wrt_rng) THEN 1671 iret = NF90_PUT_ATT (nfid,nvid,'valid_min', & 1672 & REAL(W_F(pfileid)%W_V(iv)%hist_minmax(1),KIND=4)) 1673 iret = NF90_PUT_ATT (nfid,nvid,'valid_max', & 1674 & REAL(W_F(pfileid)%W_V(iv)%hist_minmax(2),KIND=4)) 1643 1675 ENDIF 1644 iret = NF90_PUT_ATT (n cid,ncvarid,'long_name', &1645 & TRIM( title(pfileid,iv)))1646 iret = NF90_PUT_ATT (n cid,ncvarid,'online_operation', &1647 & TRIM( fullop(pfileid,iv)))1676 iret = NF90_PUT_ATT (nfid,nvid,'long_name', & 1677 & TRIM(W_F(pfileid)%W_V(iv)%title)) 1678 iret = NF90_PUT_ATT (nfid,nvid,'online_operation', & 1679 & TRIM(W_F(pfileid)%W_V(iv)%fullop)) 1648 1680 !- 1649 1681 SELECT CASE(ndim) … … 1655 1687 END SELECT 1656 1688 !- 1657 assoc=TRIM( hax_name(pfileid,var_haxid(pfileid,iv),2))&1658 & //' '//TRIM( hax_name(pfileid,var_haxid(pfileid,iv),1))1659 !- 1660 ziv = var_zaxid(pfileid,iv)1689 assoc=TRIM(W_F(pfileid)%hax_name(W_F(pfileid)%W_V(iv)%h_axid,2)) & 1690 & //' '//TRIM(W_F(pfileid)%hax_name(W_F(pfileid)%W_V(iv)%h_axid,1)) 1691 !- 1692 ziv = W_F(pfileid)%W_V(iv)%z_axid 1661 1693 IF (ziv > 0) THEN 1662 str30 = zax_name(pfileid,ziv)1694 str30 = W_F(pfileid)%zax_name(ziv) 1663 1695 assoc = TRIM(str30)//' '//TRIM(assoc) 1664 1696 ENDIF 1665 1697 !- 1666 1698 IF (itax > 0) THEN 1667 IF ( nb_tax(pfileid)> 1) THEN1668 str30 = "t_"// tax_name(pfileid,itax)1699 IF (W_F(pfileid)%n_tax > 1) THEN 1700 str30 = "t_"//W_F(pfileid)%W_V(itax)%tax_name 1669 1701 ELSE 1670 1702 str30 = "time_counter" … … 1674 1706 IF (l_dbg) THEN 1675 1707 WRITE(*,*) "histend : 2.0.n, freq_opp, freq_wrt", & 1676 & freq_opp(pfileid,iv),freq_wrt(pfileid,iv)1708 & W_F(pfileid)%W_V(iv)%freq_opp,W_F(pfileid)%W_V(iv)%freq_wrt 1677 1709 ENDIF 1678 1710 !- 1679 iret = NF90_PUT_ATT (n cid,ncvarid,'interval_operation', &1680 & REAL( freq_opp(pfileid,iv),KIND=4))1681 iret = NF90_PUT_ATT (n cid,ncvarid,'interval_write', &1682 & REAL( freq_wrt(pfileid,iv),KIND=4))1711 iret = NF90_PUT_ATT (nfid,nvid,'interval_operation', & 1712 & REAL(W_F(pfileid)%W_V(iv)%freq_opp,KIND=4)) 1713 iret = NF90_PUT_ATT (nfid,nvid,'interval_write', & 1714 & REAL(W_F(pfileid)%W_V(iv)%freq_wrt,KIND=4)) 1683 1715 ENDIF 1684 iret = NF90_PUT_ATT (n cid,ncvarid,'coordinates',TRIM(assoc))1716 iret = NF90_PUT_ATT (nfid,nvid,'coordinates',TRIM(assoc)) 1685 1717 ENDIF 1686 1718 ENDDO … … 1688 1720 ! 2.2 Add DOMAIN attributes if needed 1689 1721 !- 1690 IF ( dom_id_svg(pfileid)>= 0) THEN1691 CALL flio_dom_att (n cid,dom_id_svg(pfileid))1722 IF (W_F(pfileid)%dom_id_svg >= 0) THEN 1723 CALL flio_dom_att (nfid,W_F(pfileid)%dom_id_svg) 1692 1724 ENDIF 1693 1725 !- … … 1696 1728 IF (l_dbg) WRITE(*,*) "histend : 3.0" 1697 1729 !- 1698 iret = NF90_ENDDEF (n cid)1730 iret = NF90_ENDDEF (nfid) 1699 1731 !- 1700 1732 ! 4.0 Give some informations to the user … … 1794 1826 ! 2.0 do nothing for never operation 1795 1827 !- 1796 tmp_opp = topp(pfileid,varid)1828 tmp_opp = W_F(pfileid)%W_V(varid)%topp 1797 1829 !- 1798 1830 IF (TRIM(tmp_opp) == "never") THEN 1799 last_opp_chk(pfileid,varid)= -991800 last_wrt_chk(pfileid,varid)= -991831 W_F(pfileid)%W_V(varid)%last_opp_chk = -99 1832 W_F(pfileid)%W_V(varid)%last_wrt_chk = -99 1801 1833 ENDIF 1802 1834 !- 1803 1835 ! 3.0 We check if we need to do an operation 1804 1836 !- 1805 IF ( last_opp_chk(pfileid,varid)== pitau) THEN1837 IF (W_F(pfileid)%W_V(varid)%last_opp_chk == pitau) THEN 1806 1838 CALL ipslerr (3,"histwrite", & 1807 1839 & 'This variable has already been analysed at the present', & … … 1810 1842 !- 1811 1843 CALL isittime & 1812 & (pitau,date0(pfileid),deltat(pfileid),freq_opp(pfileid,varid), & 1813 & last_opp(pfileid,varid),last_opp_chk(pfileid,varid),do_oper) 1844 & (pitau,W_F(pfileid)%date0,W_F(pfileid)%deltat, & 1845 & W_F(pfileid)%W_V(varid)%freq_opp, & 1846 & W_F(pfileid)%W_V(varid)%last_opp, & 1847 & W_F(pfileid)%W_V(varid)%last_opp_chk,do_oper) 1814 1848 !- 1815 1849 ! 4.0 We check if we need to write the data 1816 1850 !- 1817 IF ( last_wrt_chk(pfileid,varid)== pitau) THEN1851 IF (W_F(pfileid)%W_V(varid)%last_wrt_chk == pitau) THEN 1818 1852 CALL ipslerr (3,"histwrite", & 1819 & 'This variable has already been written for the present', &1820 & 'time step', TRIM(pvarname))1853 & 'This variable as already been written for the present', & 1854 & 'time step',' ') 1821 1855 ENDIF 1822 1856 !- 1823 1857 CALL isittime & 1824 & (pitau,date0(pfileid),deltat(pfileid),freq_wrt(pfileid,varid), & 1825 & last_wrt(pfileid,varid),last_wrt_chk(pfileid,varid),do_write) 1858 & (pitau,W_F(pfileid)%date0,W_F(pfileid)%deltat, & 1859 & W_F(pfileid)%W_V(varid)%freq_wrt, & 1860 & W_F(pfileid)%W_V(varid)%last_wrt, & 1861 & W_F(pfileid)%W_V(varid)%last_wrt_chk,do_write) 1826 1862 !- 1827 1863 ! 5.0 histwrite called … … 1831 1867 !-- 5.1 Get the sizes of the data we will handle 1832 1868 !- 1833 IF ( datasz_in(pfileid,varid,1) <= 0) THEN1869 IF (W_F(pfileid)%W_V(varid)%datasz_in(1) <= 0) THEN 1834 1870 !---- There is the risk here that the user has over-sized the array. 1835 1871 !---- But how can we catch this ? 1836 1872 !---- In the worst case we will do impossible operations 1837 1873 !---- on part of the data ! 1838 datasz_in(pfileid,varid,1:3) = -11874 W_F(pfileid)%W_V(varid)%datasz_in(1:3) = -1 1839 1875 IF (l1d) THEN 1840 datasz_in(pfileid,varid,1) = SIZE(pdata_1d)1876 W_F(pfileid)%W_V(varid)%datasz_in(1) = SIZE(pdata_1d) 1841 1877 ELSE IF (l2d) THEN 1842 datasz_in(pfileid,varid,1) = SIZE(pdata_2d,DIM=1)1843 datasz_in(pfileid,varid,2) = SIZE(pdata_2d,DIM=2)1878 W_F(pfileid)%W_V(varid)%datasz_in(1) = SIZE(pdata_2d,DIM=1) 1879 W_F(pfileid)%W_V(varid)%datasz_in(2) = SIZE(pdata_2d,DIM=2) 1844 1880 ELSE IF (l3d) THEN 1845 datasz_in(pfileid,varid,1) = SIZE(pdata_3d,DIM=1)1846 datasz_in(pfileid,varid,2) = SIZE(pdata_3d,DIM=2)1847 datasz_in(pfileid,varid,3) = SIZE(pdata_3d,DIM=3)1881 W_F(pfileid)%W_V(varid)%datasz_in(1) = SIZE(pdata_3d,DIM=1) 1882 W_F(pfileid)%W_V(varid)%datasz_in(2) = SIZE(pdata_3d,DIM=2) 1883 W_F(pfileid)%W_V(varid)%datasz_in(3) = SIZE(pdata_3d,DIM=3) 1848 1884 ENDIF 1849 1885 ENDIF … … 1851 1887 !-- 5.2 The maximum size of the data will give the size of the buffer 1852 1888 !- 1853 IF ( datasz_max(pfileid,varid)<= 0) THEN1889 IF (W_F(pfileid)%W_V(varid)%datasz_max <= 0) THEN 1854 1890 largebuf = .FALSE. 1855 DO io=1, nbopp(pfileid,varid)1856 IF (INDEX(fuchnbout, sopps(pfileid,varid,io)) > 0) THEN1891 DO io=1,W_F(pfileid)%W_V(varid)%nbopp 1892 IF (INDEX(fuchnbout,W_F(pfileid)%W_V(varid)%sopps(io)) > 0) THEN 1857 1893 largebuf = .TRUE. 1858 1894 ENDIF 1859 1895 ENDDO 1860 1896 IF (largebuf) THEN 1861 datasz_max(pfileid,varid)= &1862 & scsize(pfileid,varid,1) &1863 & * scsize(pfileid,varid,2) &1864 & * scsize(pfileid,varid,3)1897 W_F(pfileid)%W_V(varid)%datasz_max = & 1898 & W_F(pfileid)%W_V(varid)%scsize(1) & 1899 & *W_F(pfileid)%W_V(varid)%scsize(2) & 1900 & *W_F(pfileid)%W_V(varid)%scsize(3) 1865 1901 ELSE 1866 1902 IF (l1d) THEN 1867 datasz_max(pfileid,varid)= &1868 & datasz_in(pfileid,varid,1)1903 W_F(pfileid)%W_V(varid)%datasz_max = & 1904 & W_F(pfileid)%W_V(varid)%datasz_in(1) 1869 1905 ELSE IF (l2d) THEN 1870 datasz_max(pfileid,varid)= &1871 & datasz_in(pfileid,varid,1) &1872 & * datasz_in(pfileid,varid,2)1906 W_F(pfileid)%W_V(varid)%datasz_max = & 1907 & W_F(pfileid)%W_V(varid)%datasz_in(1) & 1908 & *W_F(pfileid)%W_V(varid)%datasz_in(2) 1873 1909 ELSE IF (l3d) THEN 1874 datasz_max(pfileid,varid)= &1875 & datasz_in(pfileid,varid,1) &1876 & * datasz_in(pfileid,varid,2) &1877 & * datasz_in(pfileid,varid,3)1910 W_F(pfileid)%W_V(varid)%datasz_max = & 1911 & W_F(pfileid)%W_V(varid)%datasz_in(1) & 1912 & *W_F(pfileid)%W_V(varid)%datasz_in(2) & 1913 & *W_F(pfileid)%W_V(varid)%datasz_in(3) 1878 1914 ENDIF 1879 1915 ENDIF … … 1884 1920 WRITE(*,*) & 1885 1921 & c_nam//" : allocate buff_tmp for buff_sz = ", & 1886 & datasz_max(pfileid,varid)1922 & W_F(pfileid)%W_V(varid)%datasz_max 1887 1923 ENDIF 1888 ALLOCATE(buff_tmp( datasz_max(pfileid,varid)))1889 buff_tmp_sz = datasz_max(pfileid,varid)1890 ELSE IF ( datasz_max(pfileid,varid)> buff_tmp_sz) THEN1924 ALLOCATE(buff_tmp(W_F(pfileid)%W_V(varid)%datasz_max)) 1925 buff_tmp_sz = W_F(pfileid)%W_V(varid)%datasz_max 1926 ELSE IF (W_F(pfileid)%W_V(varid)%datasz_max > buff_tmp_sz) THEN 1891 1927 IF (l_dbg) THEN 1892 1928 WRITE(*,*) & 1893 1929 & c_nam//" : re-allocate buff_tmp for buff_sz = ", & 1894 & datasz_max(pfileid,varid)1930 & W_F(pfileid)%W_V(varid)%datasz_max 1895 1931 ENDIF 1896 1932 DEALLOCATE(buff_tmp) 1897 ALLOCATE(buff_tmp( datasz_max(pfileid,varid)))1898 buff_tmp_sz = datasz_max(pfileid,varid)1933 ALLOCATE(buff_tmp(W_F(pfileid)%W_V(varid)%datasz_max)) 1934 buff_tmp_sz = W_F(pfileid)%W_V(varid)%datasz_max 1899 1935 ENDIF 1900 1936 !- … … 1903 1939 !-- of the data at the same time. This should speed up things. 1904 1940 !- 1905 nbpt_out = datasz_max(pfileid,varid)1941 nbpt_out = W_F(pfileid)%W_V(varid)%datasz_max 1906 1942 IF (l1d) THEN 1907 nbpt_in1 = datasz_in(pfileid,varid,1)1908 CALL mathop ( sopps(pfileid,varid,1),nbpt_in1,pdata_1d, &1943 nbpt_in1 = W_F(pfileid)%W_V(varid)%datasz_in(1) 1944 CALL mathop (W_F(pfileid)%W_V(varid)%sopps(1),nbpt_in1,pdata_1d, & 1909 1945 & missing_val,nbindex,nindex, & 1910 & scal(pfileid,varid,1),nbpt_out,buff_tmp)1946 & W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp) 1911 1947 ELSE IF (l2d) THEN 1912 nbpt_in2(1:2) = datasz_in(pfileid,varid,1:2)1913 CALL mathop ( sopps(pfileid,varid,1),nbpt_in2,pdata_2d, &1948 nbpt_in2(1:2) = W_F(pfileid)%W_V(varid)%datasz_in(1:2) 1949 CALL mathop (W_F(pfileid)%W_V(varid)%sopps(1),nbpt_in2,pdata_2d, & 1914 1950 & missing_val,nbindex,nindex, & 1915 & scal(pfileid,varid,1),nbpt_out,buff_tmp)1951 & W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp) 1916 1952 ELSE IF (l3d) THEN 1917 nbpt_in3(1:3) = datasz_in(pfileid,varid,1:3)1918 CALL mathop ( sopps(pfileid,varid,1),nbpt_in3,pdata_3d, &1953 nbpt_in3(1:3) = W_F(pfileid)%W_V(varid)%datasz_in(1:3) 1954 CALL mathop (W_F(pfileid)%W_V(varid)%sopps(1),nbpt_in3,pdata_3d, & 1919 1955 & missing_val,nbindex,nindex, & 1920 & scal(pfileid,varid,1),nbpt_out,buff_tmp)1956 & W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp) 1921 1957 ENDIF 1922 1958 CALL histwrite_real (pfileid,varid,pitau,nbpt_out, & … … 1927 1963 !- 1928 1964 IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN 1929 last_opp_chk(pfileid,varid)= pitau1930 last_wrt_chk(pfileid,varid)= pitau1931 ELSE 1932 last_opp_chk(pfileid,varid)= -991933 last_wrt_chk(pfileid,varid)= -991965 W_F(pfileid)%W_V(varid)%last_opp_chk = pitau 1966 W_F(pfileid)%W_V(varid)%last_wrt_chk = pitau 1967 ELSE 1968 W_F(pfileid)%W_V(varid)%last_opp_chk = -99 1969 W_F(pfileid)%W_V(varid)%last_wrt_chk = -99 1934 1970 ENDIF 1935 1971 !----------------------- … … 1950 1986 LOGICAL,INTENT(IN) :: do_oper,do_write 1951 1987 !- 1952 INTEGER :: tsz,n cid,ncvarid,i,iret,ipt,itax,io,nbin,nbout1988 INTEGER :: tsz,nfid,nvid,i,iret,ipt,itax,io,nbin,nbout 1953 1989 INTEGER :: nx,ny,nz,ky,kz,kt,kc 1954 1990 INTEGER,DIMENSION(4) :: corner,edges … … 1964 2000 !- 1965 2001 IF (l_dbg) THEN 1966 WRITE(*,*) "histwrite 0.0 : VAR : ", name(pfileid,varid)2002 WRITE(*,*) "histwrite 0.0 : VAR : ",W_F(pfileid)%W_V(varid)%v_name 1967 2003 WRITE(*,*) "histwrite 0.0 : nbindex,nindex :", & 1968 2004 & nbindex,nindex(1:MIN(3,nbindex)),'...',nindex(MAX(1,nbindex-3):nbindex) … … 1971 2007 ! The sizes which can be encoutered 1972 2008 !- 1973 tsz = zsize(pfileid,varid,1) &1974 & * zsize(pfileid,varid,2) &1975 & * zsize(pfileid,varid,3)2009 tsz = W_F(pfileid)%W_V(varid)%zsize(1) & 2010 & *W_F(pfileid)%W_V(varid)%zsize(2) & 2011 & *W_F(pfileid)%W_V(varid)%zsize(3) 1976 2012 !- 1977 2013 ! 1.0 We allocate the memory needed to store the data between write … … 2017 2053 WRITE(*,*) "histwrite_real 1.1 allocate buff_tmp2 ",SIZE(buff_tmp) 2018 2054 ENDIF 2019 ALLOCATE(buff_tmp2( datasz_max(pfileid,varid)))2020 buff_tmp2_sz = datasz_max(pfileid,varid)2021 ELSE IF ( datasz_max(pfileid,varid)> buff_tmp2_sz) THEN2055 ALLOCATE(buff_tmp2(W_F(pfileid)%W_V(varid)%datasz_max)) 2056 buff_tmp2_sz = W_F(pfileid)%W_V(varid)%datasz_max 2057 ELSE IF (W_F(pfileid)%W_V(varid)%datasz_max > buff_tmp2_sz) THEN 2022 2058 IF (l_dbg) THEN 2023 2059 WRITE(*,*) "histwrite_real 1.2 re-allocate buff_tmp2 : ", & … … 2025 2061 ENDIF 2026 2062 DEALLOCATE(buff_tmp2) 2027 ALLOCATE(buff_tmp2( datasz_max(pfileid,varid)))2028 buff_tmp2_sz = datasz_max(pfileid,varid)2029 ENDIF 2030 !- 2031 rtime = pitau * deltat(pfileid)2032 tmp_opp = topp(pfileid,varid)2063 ALLOCATE(buff_tmp2(W_F(pfileid)%W_V(varid)%datasz_max)) 2064 buff_tmp2_sz = W_F(pfileid)%W_V(varid)%datasz_max 2065 ENDIF 2066 !- 2067 rtime = pitau*W_F(pfileid)%deltat 2068 tmp_opp = W_F(pfileid)%W_V(varid)%topp 2033 2069 !- 2034 2070 ! 3.0 Do the operations or transfer the slab of data into buff_tmp … … 2045 2081 !-- we started in the interface routine 2046 2082 !- 2047 DO io = 2,nbopp(i,varid),22083 DO io=2,W_F(i)%W_V(varid)%nbopp,2 2048 2084 nbin = nbout 2049 nbout = datasz_max(i,varid) 2050 CALL mathop(sopps(i,varid,io),nbin,buff_tmp,missing_val, & 2051 & nbindex,nindex,scal(i,varid,io),nbout,buff_tmp2) 2085 nbout = W_F(i)%W_V(varid)%datasz_max 2086 CALL mathop(W_F(i)%W_V(varid)%sopps(io),nbin,buff_tmp, & 2087 & missing_val,nbindex,nindex,W_F(i)%W_V(varid)%scal(io), & 2088 & nbout,buff_tmp2) 2052 2089 IF (l_dbg) THEN 2053 2090 WRITE(*,*) & 2054 & "histwrite: 3.4a nbout : ",nbin,nbout, sopps(i,varid,io)2091 & "histwrite: 3.4a nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopps(io) 2055 2092 ENDIF 2056 2093 !- 2057 2094 nbin = nbout 2058 nbout = datasz_max(i,varid) 2059 CALL mathop(sopps(i,varid,io+1),nbin,buff_tmp2,missing_val, & 2060 & nbindex,nindex,scal(i,varid,io+1),nbout,buff_tmp) 2095 nbout = W_F(i)%W_V(varid)%datasz_max 2096 CALL mathop(W_F(i)%W_V(varid)%sopps(io+1),nbin,buff_tmp2, & 2097 & missing_val,nbindex,nindex,W_F(i)%W_V(varid)%scal(io+1), & 2098 & nbout,buff_tmp) 2061 2099 IF (l_dbg) THEN 2062 2100 WRITE(*,*) & 2063 & "histwrite: 3.4b nbout : ",nbin,nbout,sopps(i,varid,io+1)2101 & "histwrite: 3.4b nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopps(io+1) 2064 2102 ENDIF 2065 2103 ENDDO … … 2071 2109 & "histwrite: 3.5 size(buff_tmp) : ",SIZE(buff_tmp) 2072 2110 WRITE(*,*) & 2073 & "histwrite: 3.5 slab in X :",zorig(i,varid,1),zsize(i,varid,1) 2111 & "histwrite: 3.5 slab in X :", & 2112 & W_F(i)%W_V(varid)%zorig(1),W_F(i)%W_V(varid)%zsize(1) 2074 2113 WRITE(*,*) & 2075 & "histwrite: 3.5 slab in Y :",zorig(i,varid,2),zsize(i,varid,2) 2114 & "histwrite: 3.5 slab in Y :", & 2115 & W_F(i)%W_V(varid)%zorig(2),W_F(i)%W_V(varid)%zsize(2) 2076 2116 WRITE(*,*) & 2077 & "histwrite: 3.5 slab in Z :",zorig(i,varid,3),zsize(i,varid,3) 2117 & "histwrite: 3.5 slab in Z :", & 2118 & W_F(i)%W_V(varid)%zorig(3),W_F(i)%W_V(varid)%zsize(3) 2078 2119 WRITE(*,*) & 2079 2120 & "histwrite: 3.5 slab of input:", & 2080 & scsize(i,varid,1),scsize(i,varid,2),scsize(i,varid,3) 2121 & W_F(i)%W_V(varid)%scsize(1), & 2122 & W_F(i)%W_V(varid)%scsize(2), & 2123 & W_F(i)%W_V(varid)%scsize(3) 2081 2124 ENDIF 2082 2125 !--- 2083 2126 !-- We have to consider blocks of contiguous data 2084 2127 !--- 2085 nx=MAX(zsize(i,varid,1),1) 2086 ny=MAX(zsize(i,varid,2),1) 2087 nz=MAX(zsize(i,varid,3),1) 2088 IF ( (zorig(i,varid,1) == 1) & 2089 & .AND.(zsize(i,varid,1) == scsize(i,varid,1)) & 2090 & .AND.(zorig(i,varid,2) == 1) & 2091 & .AND.(zsize(i,varid,2) == scsize(i,varid,2))) THEN 2092 kt = (zorig(i,varid,3)-1)*nx*ny 2128 nx=MAX(W_F(i)%W_V(varid)%zsize(1),1) 2129 ny=MAX(W_F(i)%W_V(varid)%zsize(2),1) 2130 nz=MAX(W_F(i)%W_V(varid)%zsize(3),1) 2131 IF ( (W_F(i)%W_V(varid)%zorig(1) == 1) & 2132 & .AND.( W_F(i)%W_V(varid)%zsize(1) & 2133 & == W_F(i)%W_V(varid)%scsize(1)) & 2134 & .AND.(W_F(i)%W_V(varid)%zorig(2) == 1) & 2135 & .AND.( W_F(i)%W_V(varid)%zsize(2) & 2136 & == W_F(i)%W_V(varid)%scsize(2))) THEN 2137 kt = (W_F(i)%W_V(varid)%zorig(3)-1)*nx*ny 2093 2138 buff_tmp2(1:nx*ny*nz) = buff_tmp(kt+1:kt+nx*ny*nz) 2094 ELSEIF ( (zorig(i,varid,1) == 1) & 2095 & .AND.(zsize(i,varid,1) == scsize(i,varid,1))) THEN 2139 ELSEIF ( (W_F(i)%W_V(varid)%zorig(1) == 1) & 2140 & .AND.( W_F(i)%W_V(varid)%zsize(1) & 2141 & == W_F(i)%W_V(varid)%scsize(1))) THEN 2096 2142 kc = -nx*ny 2097 DO kz= zorig(i,varid,3),zorig(i,varid,3)+nz-12143 DO kz=W_F(i)%W_V(varid)%zorig(3),W_F(i)%W_V(varid)%zorig(3)+nz-1 2098 2144 kc = kc+nx*ny 2099 kt = ((kz-1)*scsize(i,varid,2)+zorig(i,varid,2)-1)*nx 2145 kt = ( (kz-1)*W_F(i)%W_V(varid)%scsize(2) & 2146 & +W_F(i)%W_V(varid)%zorig(2)-1)*nx 2100 2147 buff_tmp2(kc+1:kc+nx*ny) = buff_tmp(kt+1:kt+nx*ny) 2101 2148 ENDDO 2102 2149 ELSE 2103 2150 kc = -nx 2104 DO kz= zorig(i,varid,3),zorig(i,varid,3)+nz-12105 DO ky= zorig(i,varid,2),zorig(i,varid,2)+ny-12151 DO kz=W_F(i)%W_V(varid)%zorig(3),W_F(i)%W_V(varid)%zorig(3)+nz-1 2152 DO ky=W_F(i)%W_V(varid)%zorig(2),W_F(i)%W_V(varid)%zorig(2)+ny-1 2106 2153 kc = kc+nx 2107 kt = ((kz-1)*scsize(i,varid,2)+ky-1)*scsize(i,varid,1) & 2108 & +zorig(i,varid,1)-1 2154 kt = ((kz-1)*W_F(i)%W_V(varid)%scsize(2)+ky-1) & 2155 & *W_F(i)%W_V(varid)%scsize(1) & 2156 & +W_F(i)%W_V(varid)%zorig(1)-1 2109 2157 buff_tmp2(kc+1:kc+nx) = buff_tmp(kt+1:kt+nx) 2110 2158 ENDDO … … 2117 2165 & TRIM(tmp_opp),' ---- ',LEN_TRIM(tmp_opp),nbindex 2118 2166 !- 2119 IF ( hist_calc_rng(pfileid,varid)) THEN2120 hist_minmax(pfileid,varid,1) = &2121 & MIN( hist_minmax(pfileid,varid,1), &2167 IF (W_F(pfileid)%W_V(varid)%hist_calc_rng) THEN 2168 W_F(pfileid)%W_V(varid)%hist_minmax(1) = & 2169 & MIN(W_F(pfileid)%W_V(varid)%hist_minmax(1), & 2122 2170 & MINVAL(buff_tmp2(1:tsz),MASK=buff_tmp2(1:tsz) /= missing_val)) 2123 hist_minmax(pfileid,varid,2) = &2124 & MAX( hist_minmax(pfileid,varid,2), &2171 W_F(pfileid)%W_V(varid)%hist_minmax(2) = & 2172 & MAX(W_F(pfileid)%W_V(varid)%hist_minmax(2), & 2125 2173 & MAXVAL(buff_tmp2(1:tsz),MASK=buff_tmp2(1:tsz) /= missing_val)) 2126 2174 ENDIF … … 2131 2179 IF (l_dbg) WRITE(*,*) "histwrite: 5.0",pfileid,"tsz :",tsz 2132 2180 !- 2133 ipt = point(pfileid,varid)2181 ipt = W_F(pfileid)%W_V(varid)%point 2134 2182 !- 2135 2183 ! WRITE(*,*) 'OPE ipt, buffer :',pvarname,ipt,varid 2136 2184 !- 2137 2185 IF ( (TRIM(tmp_opp) /= "inst") & 2138 &.AND.(TRIM(tmp_opp) /= "once") ) THEN2186 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2139 2187 CALL moycum(tmp_opp,tsz,buffer(ipt:), & 2140 & buff_tmp2,nb_opp(pfileid,varid))2141 ENDIF 2142 !- 2143 last_opp(pfileid,varid)= pitau2144 nb_opp(pfileid,varid) = nb_opp(pfileid,varid)+12188 & buff_tmp2,W_F(pfileid)%W_V(varid)%nb_opp) 2189 ENDIF 2190 !- 2191 W_F(pfileid)%W_V(varid)%last_opp = pitau 2192 W_F(pfileid)%W_V(varid)%nb_opp = W_F(pfileid)%W_V(varid)%nb_opp+1 2145 2193 !- 2146 2194 ENDIF … … 2152 2200 IF (do_write) THEN 2153 2201 !- 2154 n cvarid = ncvar_ids(pfileid,varid)2155 n cid = ncdf_ids(pfileid)2202 nfid = W_F(pfileid)%ncfid 2203 nvid = W_F(pfileid)%W_V(varid)%ncvid 2156 2204 !- 2157 2205 !-- 6.1 Do the operations that are needed before writting … … 2160 2208 !- 2161 2209 IF ( (TRIM(tmp_opp) /= "inst") & 2162 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2163 rtime = (rtime+last_wrt(pfileid,varid)*deltat(pfileid))/2.0 2210 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2211 rtime = ( rtime & 2212 & +W_F(pfileid)%W_V(varid)%last_wrt*W_F(pfileid)%deltat)/2.0 2164 2213 ENDIF 2165 2214 !- … … 2167 2216 !- 2168 2217 IF ( (TRIM(tmp_opp) /= "l_max") & 2169 &.AND.(TRIM(tmp_opp) /= "l_min") &2170 &.AND.(TRIM(tmp_opp) /= "once") ) THEN2218 & .AND.(TRIM(tmp_opp) /= "l_min") & 2219 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2171 2220 !- 2172 2221 IF (l_dbg) WRITE(*,*) "histwrite: 6.2",pfileid 2173 2222 !- 2174 itax = var_axid(pfileid,varid)2175 itime = nb_wrt(pfileid,varid)+12176 !- 2177 IF ( tax_last(pfileid,itax)< itime) THEN2178 iret = NF90_PUT_VAR (n cid,tdimid(pfileid,itax),(/ rtime /), &2179 & 2180 tax_last(pfileid,itax)= itime2223 itax = W_F(pfileid)%W_V(varid)%t_axid 2224 itime = W_F(pfileid)%W_V(varid)%nb_wrt+1 2225 !- 2226 IF (W_F(pfileid)%W_V(itax)%tax_last < itime) THEN 2227 iret = NF90_PUT_VAR (nfid,W_F(pfileid)%W_V(itax)%tdimid, & 2228 & (/ rtime /),start=(/ itime /),count=(/ 1 /)) 2229 W_F(pfileid)%W_V(itax)%tax_last = itime 2181 2230 ENDIF 2182 2231 ELSE … … 2188 2237 !- 2189 2238 IF (l_dbg) THEN 2190 WRITE(*,*) "histwrite: 6.3",pfileid,n cid,ncvarid,varid,itime2191 ENDIF 2192 !- 2193 IF ( scsize(pfileid,varid,3) == 1) THEN2194 IF ( regular(pfileid)) THEN2239 WRITE(*,*) "histwrite: 6.3",pfileid,nfid,nvid,varid,itime 2240 ENDIF 2241 !- 2242 IF (W_F(pfileid)%W_V(varid)%scsize(3) == 1) THEN 2243 IF (W_F(pfileid)%regular) THEN 2195 2244 corner(1:4) = (/ 1,1,itime,0 /) 2196 edges(1:4) = (/ zsize(pfileid,varid,1), &2197 & zsize(pfileid,varid,2),1,0 /)2245 edges(1:4) = (/ W_F(pfileid)%W_V(varid)%zsize(1), & 2246 & W_F(pfileid)%W_V(varid)%zsize(2),1,0 /) 2198 2247 ELSE 2199 2248 corner(1:4) = (/ 1,itime,0,0 /) 2200 edges(1:4) = (/ zsize(pfileid,varid,1),1,0,0 /)2249 edges(1:4) = (/ W_F(pfileid)%W_V(varid)%zsize(1),1,0,0 /) 2201 2250 ENDIF 2202 2251 ELSE 2203 IF ( regular(pfileid)) THEN2252 IF (W_F(pfileid)%regular) THEN 2204 2253 corner(1:4) = (/ 1,1,1,itime /) 2205 edges(1:4) = (/ zsize(pfileid,varid,1), &2206 & zsize(pfileid,varid,2), &2207 & zsize(pfileid,varid,3),1 /)2254 edges(1:4) = (/ W_F(pfileid)%W_V(varid)%zsize(1), & 2255 & W_F(pfileid)%W_V(varid)%zsize(2), & 2256 & W_F(pfileid)%W_V(varid)%zsize(3),1 /) 2208 2257 ELSE 2209 2258 corner(1:4) = (/ 1,1,itime,0 /) 2210 edges(1:4) = (/ zsize(pfileid,varid,1), &2211 & zsize(pfileid,varid,3),1,0 /)2259 edges(1:4) = (/ W_F(pfileid)%W_V(varid)%zsize(1), & 2260 & W_F(pfileid)%W_V(varid)%zsize(3),1,0 /) 2212 2261 ENDIF 2213 2262 ENDIF 2214 2263 !- 2215 ipt = point(pfileid,varid)2264 ipt = W_F(pfileid)%W_V(varid)%point 2216 2265 !- 2217 2266 IF ( (TRIM(tmp_opp) /= "inst") & 2218 2267 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2219 iret = NF90_PUT_VAR (n cid,ncvarid,buffer(ipt:), &2268 iret = NF90_PUT_VAR (nfid,nvid,buffer(ipt:), & 2220 2269 & start=corner(1:4),count=edges(1:4)) 2221 2270 ELSE 2222 iret = NF90_PUT_VAR (n cid,ncvarid,buff_tmp2, &2271 iret = NF90_PUT_VAR (nfid,nvid,buff_tmp2, & 2223 2272 & start=corner(1:4),count=edges(1:4)) 2224 2273 ENDIF 2225 2274 !- 2226 last_wrt(pfileid,varid)= pitau2227 nb_wrt(pfileid,varid) = nb_wrt(pfileid,varid)+12228 nb_opp(pfileid,varid)= 02275 W_F(pfileid)%W_V(varid)%last_wrt = pitau 2276 W_F(pfileid)%W_V(varid)%nb_wrt = W_F(pfileid)%W_V(varid)%nb_wrt+1 2277 W_F(pfileid)%W_V(varid)%nb_opp = 0 2229 2278 !--- 2230 2279 ! After the write the file can be synchronized so that no data is … … 2233 2282 ! needed here to switch to this mode. 2234 2283 !--- 2235 ! iret = NF90_SYNC (n cid)2284 ! iret = NF90_SYNC (nfid) 2236 2285 !- 2237 2286 ENDIF … … 2281 2330 !- 2282 2331 IF (overlap(pfid) <= 0) THEN 2283 IF ( nb_var(pfid)> 6) THEN2284 overlap(pfid) = nb_var(pfid)/3*22332 IF (W_F(pfid)%n_var > 6) THEN 2333 overlap(pfid) = W_F(pfid)%n_var/3*2 2285 2334 ELSE 2286 overlap(pfid) = nb_var(pfid)2335 overlap(pfid) = W_F(pfid)%n_var 2287 2336 ENDIF 2288 2337 ENDIF … … 2290 2339 !-- 1.1 Find the position of this string 2291 2340 !- 2292 CALL find_str ( name(pfid,1:nb_var(pfid)),pvarname,pos)2341 CALL find_str (W_F(pfid)%W_V(1:W_F(pfid)%n_var)%v_name,pvarname,pos) 2293 2342 IF (pos > 0) THEN 2294 2343 pvid = pos … … 2323 2372 !---- 1.3 Check if we have found the right overlap 2324 2373 !- 2325 IF (varseq_len(pfid) .GE.overlap(pfid)*2) THEN2374 IF (varseq_len(pfid) >= overlap(pfid)*2) THEN 2326 2375 !- 2327 2376 !------ We skip a few variables if needed as they could come … … 2351 2400 pvid = varseq(pfid,nn) 2352 2401 !- 2353 IF (TRIM( name(pfid,pvid)) /= TRIM(pvarname)) THEN2354 CALL find_str ( name(pfid,1:nb_var(pfid)),pvarname,pos)2402 IF (TRIM(W_F(pfid)%W_V(pvid)%v_name) /= TRIM(pvarname)) THEN 2403 CALL find_str (W_F(pfid)%W_V(1:W_F(pfid)%n_var)%v_name,pvarname,pos) 2355 2404 IF (pos > 0) THEN 2356 2405 pvid = pos … … 2371 2420 ENDIF 2372 2421 !- 2373 IF (varseq_err(pfid) .GE.10) THEN2422 IF (varseq_err(pfid) >= 10) THEN 2374 2423 WRITE(str70,'("for file ",I3)') pfid 2375 2424 CALL ipslerr (2,"histvar_seq", & … … 2400 2449 INTEGER,INTENT(in),OPTIONAL :: file 2401 2450 !- 2402 INTEGER :: ifile,n cid,iret2451 INTEGER :: ifile,nfid,iret 2403 2452 !- 2404 2453 LOGICAL :: file_exists … … 2411 2460 ! 1.The loop on files to synchronise 2412 2461 !- 2413 DO ifile =1,nb_files2462 DO ifile=1,nb_files 2414 2463 !- 2415 2464 IF (PRESENT(file)) THEN … … 2423 2472 WRITE(*,*) 'Synchronising specified file number :',file 2424 2473 ENDIF 2425 n cid = ncdf_ids(ifile)2426 iret = NF90_SYNC (n cid)2474 nfid = W_F(ifile)%ncfid 2475 iret = NF90_SYNC (nfid) 2427 2476 ENDIF 2428 2477 !- … … 2443 2492 INTEGER,INTENT(in),OPTIONAL :: fid 2444 2493 !- 2445 INTEGER :: ifile,n cid,iret,iv2494 INTEGER :: ifile,nfid,nvid,iret,iv 2446 2495 INTEGER :: start_loop,end_loop 2447 2496 CHARACTER(LEN=70) :: str70 … … 2462 2511 DO ifile=start_loop,end_loop 2463 2512 IF (l_dbg) WRITE(*,*) 'Closing specified file number :',ifile 2464 n cid = ncdf_ids(ifile)2465 iret = NF90_REDEF (n cid)2513 nfid = W_F(ifile)%ncfid 2514 iret = NF90_REDEF (nfid) 2466 2515 !--- 2467 2516 !-- 1. Loop on the number of variables to add some final information 2468 2517 !--- 2469 IF (l_dbg) WRITE(*,*) 'Entering loop on vars : ', nb_var(ifile)2470 DO iv=1, nb_var(ifile)2471 IF ( hist_wrt_rng(ifile,iv)) THEN2518 IF (l_dbg) WRITE(*,*) 'Entering loop on vars : ',W_F(ifile)%n_var 2519 DO iv=1,W_F(ifile)%n_var 2520 IF (W_F(ifile)%W_V(iv)%hist_wrt_rng) THEN 2472 2521 IF (l_dbg) THEN 2473 2522 WRITE(*,*) 'min value for file :',ifile,' var n. :',iv, & 2474 & ' is : ', hist_minmax(ifile,iv,1)2523 & ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(1) 2475 2524 WRITE(*,*) 'max value for file :',ifile,' var n. :',iv, & 2476 & ' is : ', hist_minmax(ifile,iv,2)2525 & ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(2) 2477 2526 ENDIF 2478 IF ( hist_calc_rng(ifile,iv)) THEN2527 IF (W_F(ifile)%W_V(iv)%hist_calc_rng) THEN 2479 2528 !-------- Put the min and max values on the file 2480 iret = NF90_PUT_ATT (ncid,ncvar_ids(ifile,iv),'valid_min', & 2481 & REAL(hist_minmax(ifile,iv,1),KIND=4)) 2482 iret = NF90_PUT_ATT (ncid,ncvar_ids(ifile,iv),'valid_max', & 2483 & REAL(hist_minmax(ifile,iv,2),KIND=4)) 2529 nvid = W_F(ifile)%W_V(iv)%ncvid 2530 iret = NF90_PUT_ATT (nfid,nvid,'valid_min', & 2531 & REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=4)) 2532 iret = NF90_PUT_ATT (nfid,nvid,'valid_max', & 2533 & REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=4)) 2484 2534 ENDIF 2485 2535 ENDIF … … 2488 2538 !-- 2. Close the file 2489 2539 !--- 2490 IF (l_dbg) WRITE(*,*) 'close file :',n cid2491 iret = NF90_CLOSE (n cid)2540 IF (l_dbg) WRITE(*,*) 'close file :',nfid 2541 iret = NF90_CLOSE (nfid) 2492 2542 IF (iret /= NF90_NOERR) THEN 2493 2543 WRITE(str70,'("This file has been already closed :",I3)') ifile
Note: See TracChangeset
for help on using the changeset viewer.
