Changeset 856 for IOIPSL/trunk
- Timestamp:
- 12/16/09 11:30:32 (15 years ago)
- File:
-
- 1 edited
-
IOIPSL/trunk/src/histcom.f90 (modified) (120 diffs)
Legend:
- Unmodified
- Added
- Removed
-
IOIPSL/trunk/src/histcom.f90
r845 r856 55 55 !- 56 56 !- INPUT 57 !- pfileid: The ID of the file on which this variable is to be,57 !- idf : The ID of the file on which this variable is to be, 58 58 !- written. The variable should have been defined in 59 59 !- this file before. … … 108 108 REAL :: freq_opp,freq_wrt 109 109 INTEGER :: & 110 & last_opp,last_wrt,last_opp_chk,last_wrt_chk,nb_opp,nb_wrt ,point110 & last_opp,last_wrt,last_opp_chk,last_wrt_chk,nb_opp,nb_wrt 111 111 !- For future optimization 112 REAL,ALLOCATABLE,DIMENSION(:) :: t_bf 112 113 !# REAL,ALLOCATABLE,DIMENSION(:) :: V_1_D 113 114 !# REAL,ALLOCATABLE,DIMENSION(:,:) :: V_2_D … … 148 149 INTEGER,SAVE :: nb_files=0 149 150 !- 150 ! Book keeping for the buffers151 !-152 INTEGER,SAVE :: buff_pos=0153 REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buffer154 !-155 151 ! A list of functions which require special action 156 152 ! (Needs to be updated when functions are added … … 169 165 & (pfilename,pim,plon,pjm,plat, & 170 166 & par_orix,par_szx,par_oriy,par_szy, & 171 & pitau0,pdate0,pdeltat,phoriid, pfileid,domain_id,nb_bits)167 & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,nb_bits) 172 168 !--------------------------------------------------------------------- 173 169 !- This is just an interface for histbeg_regular in case when … … 201 197 !- 202 198 !- phoriid : ID of the horizontal grid 203 !- pfileid: ID of the netcdf file199 !- idf : ID of the netcdf file 204 200 !- 205 201 !- Optional INPUT arguments … … 227 223 INTEGER,INTENT(IN) :: pitau0 228 224 REAL,INTENT(IN) :: pdate0,pdeltat 229 INTEGER,INTENT(OUT) :: pfileid,phoriid225 INTEGER,INTENT(OUT) :: idf,phoriid 230 226 INTEGER,INTENT(IN),OPTIONAL :: domain_id,nb_bits 231 227 !- … … 245 241 & (pfilename,pim,lon_tmp,pjm,lat_tmp, & 246 242 & par_orix,par_szx,par_oriy,par_szy, & 247 & pitau0,pdate0,pdeltat,phoriid, pfileid, &243 & pitau0,pdate0,pdeltat,phoriid,idf, & 248 244 & .TRUE.,domain_id,nb_bits) 249 245 !- … … 255 251 & (pfilename,pim,plon,pjm,plat, & 256 252 & par_orix,par_szx,par_oriy,par_szy, & 257 & pitau0,pdate0,pdeltat,phoriid, pfileid, &253 & pitau0,pdate0,pdeltat,phoriid,idf, & 258 254 & opt_rectilinear,domain_id,nb_bits) 259 255 !--------------------------------------------------------------------- … … 289 285 !- 290 286 !- phoriid : ID of the horizontal grid 291 !- pfileid: ID of the netcdf file287 !- idf : ID of the netcdf file 292 288 !- 293 289 !- Optional INPUT arguments … … 315 311 INTEGER,INTENT(IN) :: pitau0 316 312 REAL,INTENT(IN) :: pdate0,pdeltat 317 INTEGER,INTENT(OUT) :: pfileid,phoriid313 INTEGER,INTENT(OUT) :: idf,phoriid 318 314 LOGICAL,INTENT(IN),OPTIONAL :: opt_rectilinear 319 315 INTEGER,INTENT(IN),OPTIONAL :: domain_id,nb_bits … … 335 331 & 'in histcom.f90 in order to accomodate all these files',' ') 336 332 ENDIF 337 pfileid= nb_files333 idf = nb_files 338 334 !- 339 335 ! 1.0 Transfering into the common for future use … … 341 337 IF (l_dbg) WRITE(*,*) "histbeg_regular 1.0" 342 338 !- 343 W_F( pfileid)%itau0 = pitau0344 W_F( pfileid)%date0 = pdate0345 W_F( pfileid)%deltat = pdeltat339 W_F(idf)%itau0 = pitau0 340 W_F(idf)%date0 = pdate0 341 W_F(idf)%deltat = pdeltat 346 342 !- 347 343 IF (PRESENT(opt_rectilinear)) THEN … … 355 351 IF (l_dbg) WRITE(*,*) "histbeg_regular 2.0" 356 352 !- 357 W_F( pfileid)%n_var = 0358 W_F( pfileid)%n_tax = 0359 W_F( pfileid)%n_hax = 0360 W_F( pfileid)%n_zax = 0361 !- 362 W_F( pfileid)%slab_ori(1:2) = (/ par_orix,par_oriy /)363 W_F( pfileid)%slab_sz(1:2) = (/ par_szx, par_szy /)353 W_F(idf)%n_var = 0 354 W_F(idf)%n_tax = 0 355 W_F(idf)%n_hax = 0 356 W_F(idf)%n_zax = 0 357 !- 358 W_F(idf)%slab_ori(1:2) = (/ par_orix,par_oriy /) 359 W_F(idf)%slab_sz(1:2) = (/ par_szx, par_szy /) 364 360 !- 365 361 ! 3.0 Opening netcdf file and defining dimensions … … 392 388 !- 393 389 IF (rectilinear) THEN 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)390 iret = NF90_DEF_DIM (nfid,'lon',par_szx,W_F(idf)%xid) 391 iret = NF90_DEF_DIM (nfid,'lat',par_szy,W_F(idf)%yid) 392 ELSE 393 iret = NF90_DEF_DIM (nfid,'x',par_szx,W_F(idf)%xid) 394 iret = NF90_DEF_DIM (nfid,'y',par_szy,W_F(idf)%yid) 399 395 ENDIF 400 396 !- … … 417 413 !- 418 414 IF (PRESENT(domain_id)) THEN 419 W_F( pfileid)%dom_id_svg = domain_id420 ENDIF 421 W_F( pfileid)%ncfid = nfid422 W_F( pfileid)%full_size(1:2) = (/ pim,pjm /)415 W_F(idf)%dom_id_svg = domain_id 416 ENDIF 417 W_F(idf)%ncfid = nfid 418 W_F(idf)%full_size(1:2) = (/ pim,pjm /) 423 419 !- 424 420 ! 6.0 storing the geographical coordinates 425 421 !- 426 W_F( pfileid)%regular=.TRUE.427 !- 428 CALL histhori_regular ( pfileid,pim,plon,pjm,plat, &422 W_F(idf)%regular=.TRUE. 423 !- 424 CALL histhori_regular (idf,pim,plon,pjm,plat, & 429 425 & ' ','Default grid',phoriid,rectilinear) 430 426 !----------------------------- … … 433 429 SUBROUTINE histbeg_irregular & 434 430 & (pfilename,pim,plon,plon_bounds,plat,plat_bounds, & 435 & pitau0,pdate0,pdeltat,phoriid, pfileid,domain_id,nb_bits)431 & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,nb_bits) 436 432 !--------------------------------------------------------------------- 437 433 !- This subroutine initializes a netcdf file and returns the ID. … … 458 454 !- 459 455 !- phoriid : ID of the horizontal grid 460 !- pfileid: ID of the netcdf file456 !- idf : ID of the netcdf file 461 457 !- 462 458 !- Optional INPUT arguments … … 483 479 INTEGER,INTENT(IN) :: pitau0 484 480 REAL,INTENT(IN) :: pdate0,pdeltat 485 INTEGER,INTENT(OUT) :: pfileid,phoriid481 INTEGER,INTENT(OUT) :: idf,phoriid 486 482 INTEGER,INTENT(IN),OPTIONAL :: domain_id,nb_bits 487 483 !- … … 501 497 & 'in histcom.f90 in order to accomodate all these files',' ') 502 498 ENDIF 503 pfileid= nb_files499 idf = nb_files 504 500 !- 505 501 ! 1.0 Transfering into the common for future use … … 507 503 IF (l_dbg) WRITE(*,*) "histbeg_irregular 1.0" 508 504 !- 509 W_F( pfileid)%itau0 = pitau0510 W_F( pfileid)%date0 = pdate0511 W_F( pfileid)%deltat = pdeltat505 W_F(idf)%itau0 = pitau0 506 W_F(idf)%date0 = pdate0 507 W_F(idf)%deltat = pdeltat 512 508 !- 513 509 ! 2.0 Initializes all variables for this file … … 515 511 IF (l_dbg) WRITE(*,*) "histbeg_irregular 2.0" 516 512 !- 517 W_F( pfileid)%n_var = 0518 W_F( pfileid)%n_tax = 0519 W_F( pfileid)%n_hax = 0520 W_F( pfileid)%n_zax = 0521 !- 522 W_F( pfileid)%slab_ori(1:2) = (/ 1,1 /)523 W_F( pfileid)%slab_sz(1:2) = (/ pim,1 /)513 W_F(idf)%n_var = 0 514 W_F(idf)%n_tax = 0 515 W_F(idf)%n_hax = 0 516 W_F(idf)%n_zax = 0 517 !- 518 W_F(idf)%slab_ori(1:2) = (/ 1,1 /) 519 W_F(idf)%slab_sz(1:2) = (/ pim,1 /) 524 520 !- 525 521 ! 3.0 Opening netcdf file and defining dimensions … … 551 547 iret = NF90_CREATE (file,m_c,nfid) 552 548 !- 553 iret = NF90_DEF_DIM (nfid,'x',pim,W_F( pfileid)%xid)554 W_F( pfileid)%yid = 0549 iret = NF90_DEF_DIM (nfid,'x',pim,W_F(idf)%xid) 550 W_F(idf)%yid = 0 555 551 !- 556 552 ! 4.0 Declaring the geographical coordinates and other attributes … … 572 568 !- 573 569 IF (PRESENT(domain_id)) THEN 574 W_F( pfileid)%dom_id_svg = domain_id575 ENDIF 576 W_F( pfileid)%ncfid = nfid577 W_F( pfileid)%full_size(1:2) = (/ pim,1 /)570 W_F(idf)%dom_id_svg = domain_id 571 ENDIF 572 W_F(idf)%ncfid = nfid 573 W_F(idf)%full_size(1:2) = (/ pim,1 /) 578 574 !- 579 575 ! 6.0 storing the geographical coordinates 580 576 !- 581 W_F( pfileid)%regular=.FALSE.577 W_F(idf)%regular=.FALSE. 582 578 !- 583 579 CALL histhori_irregular & 584 & ( pfileid,pim,plon,plon_bounds,plat,plat_bounds, &580 & (idf,pim,plon,plon_bounds,plat,plat_bounds, & 585 581 & ' ','Default grid',phoriid) 586 582 !------------------------------- … … 588 584 !=== 589 585 SUBROUTINE histhori_regular & 590 & ( pfileid,pim,plon,pjm,plat,phname,phtitle,phid,opt_rectilinear)586 & (idf,pim,plon,pjm,plat,phname,phtitle,phid,opt_rectilinear) 591 587 !--------------------------------------------------------------------- 592 588 !- This subroutine is made to declare a new horizontale grid. … … 600 596 !- INPUT 601 597 !- 602 !- pfileid: The id of the file to which the grid should be added598 !- idf : The id of the file to which the grid should be added 603 599 !- pim : Size in the longitude direction 604 600 !- plon : The longitudes … … 619 615 IMPLICIT NONE 620 616 !- 621 INTEGER,INTENT(IN) :: pfileid,pim,pjm617 INTEGER,INTENT(IN) :: idf,pim,pjm 622 618 REAL,INTENT(IN),DIMENSION(pim,pjm) :: plon,plat 623 619 CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle … … 639 635 ! 1.0 Check that all fits in the buffers 640 636 !- 641 IF ( (pim /= W_F( pfileid)%full_size(1)) &642 & .OR.(pjm /= W_F( pfileid)%full_size(2)) ) THEN637 IF ( (pim /= W_F(idf)%full_size(1)) & 638 & .OR.(pjm /= W_F(idf)%full_size(2)) ) THEN 643 639 CALL ipslerr (3,"histhori", & 644 640 & 'The new horizontal grid does not have the same size', & … … 657 653 IF (l_dbg) WRITE(*,*) "histhori_regular 1.0" 658 654 !- 659 nfid = W_F( pfileid)%ncfid655 nfid = W_F(idf)%ncfid 660 656 !- 661 657 ndim = 2 662 dims(1:2) = (/ W_F( pfileid)%xid,W_F(pfileid)%yid /)658 dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /) 663 659 !- 664 660 tmp_name = phname 665 661 IF (rectilinear) THEN 666 IF (W_F( pfileid)%n_hax == 0) THEN662 IF (W_F(idf)%n_hax == 0) THEN 667 663 lon_name = 'lon' 668 664 lat_name = 'lat' … … 672 668 ENDIF 673 669 ELSE 674 IF (W_F( pfileid)%n_hax == 0) THEN670 IF (W_F(idf)%n_hax == 0) THEN 675 671 lon_name = 'nav_lon' 676 672 lat_name = 'nav_lat' … … 683 679 ! 1.2 Save the informations 684 680 !- 685 phid = W_F( pfileid)%n_hax+1686 W_F( pfileid)%n_hax = phid687 W_F( pfileid)%hax_name(phid,1:2) = (/ lon_name,lat_name /)681 phid = W_F(idf)%n_hax+1 682 W_F(idf)%n_hax = phid 683 W_F(idf)%hax_name(phid,1:2) = (/ lon_name,lat_name /) 688 684 tmp_title = phtitle 689 685 !- … … 694 690 IF (rectilinear) THEN 695 691 ndim = 1 696 dims(1:1) = (/ W_F( pfileid)%xid /)692 dims(1:1) = (/ W_F(idf)%xid /) 697 693 ENDIF 698 694 iret = NF90_DEF_VAR (nfid,lon_name,NF90_FLOAT,dims(1:ndim),nlonid) … … 715 711 IF (rectilinear) THEN 716 712 ndim = 1 717 dims(1:1) = (/ W_F( pfileid)%yid /)713 dims(1:1) = (/ W_F(idf)%yid /) 718 714 ENDIF 719 715 iret = NF90_DEF_VAR (nfid,lat_name,NF90_FLOAT,dims(1:ndim),nlatid) … … 736 732 IF (l_dbg) WRITE(*,*) "histhori_regular 4.0" 737 733 !- 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)734 orix = W_F(idf)%slab_ori(1) 735 oriy = W_F(idf)%slab_ori(2) 736 par_szx = W_F(idf)%slab_sz(1) 737 par_szy = W_F(idf)%slab_sz(2) 742 738 !- 743 739 ! Transfer the longitude … … 764 760 !=== 765 761 SUBROUTINE histhori_irregular & 766 & ( pfileid,pim,plon,plon_bounds,plat,plat_bounds, &762 & (idf,pim,plon,plon_bounds,plat,plat_bounds, & 767 763 & phname,phtitle,phid) 768 764 !--------------------------------------------------------------------- … … 777 773 !- INPUT 778 774 !- 779 !- pfileid: The id of the file to which the grid should be added775 !- idf : The id of the file to which the grid should be added 780 776 !- pim : Size in the longitude direction 781 777 !- plon : The longitudes … … 792 788 IMPLICIT NONE 793 789 !- 794 INTEGER,INTENT(IN) :: pfileid,pim790 INTEGER,INTENT(IN) :: idf,pim 795 791 REAL,DIMENSION(pim),INTENT(IN) :: plon,plat 796 792 REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds … … 814 810 ! 1.0 Check that all fits in the buffers 815 811 !- 816 IF ( (pim /= W_F( pfileid)%full_size(1)) &817 & .OR.(W_F( pfileid)%full_size(2) /= 1) ) THEN812 IF ( (pim /= W_F(idf)%full_size(1)) & 813 & .OR.(W_F(idf)%full_size(2) /= 1) ) THEN 818 814 CALL ipslerr (3,"histhori", & 819 815 & 'The new horizontal grid does not have the same size', & … … 826 822 IF (l_dbg) WRITE(*,*) 'histhori_irregular 1.0' 827 823 !- 828 nfid = W_F( pfileid)%ncfid824 nfid = W_F(idf)%ncfid 829 825 !- 830 826 IF (SIZE(plon_bounds,DIM=1) == pim) THEN … … 845 841 iret = NF90_DEF_DIM (nfid,'nbnd',nbbounds,twoid) 846 842 ndim = 1 847 dims(1) = W_F( pfileid)%xid843 dims(1) = W_F(idf)%xid 848 844 ndimb = 2 849 dimsb(1:2) = (/ twoid,W_F( pfileid)%xid /)845 dimsb(1:2) = (/ twoid,W_F(idf)%xid /) 850 846 !- 851 847 tmp_name = phname 852 IF (W_F( pfileid)%n_hax == 0) THEN848 IF (W_F(idf)%n_hax == 0) THEN 853 849 lon_name = 'nav_lon' 854 850 lat_name = 'nav_lat' … … 862 858 ! 1.2 Save the informations 863 859 !- 864 phid = W_F( pfileid)%n_hax+1865 W_F( pfileid)%n_hax = phid866 W_F( pfileid)%hax_name(phid,1:2) = (/ lon_name,lat_name /)860 phid = W_F(idf)%n_hax+1 861 W_F(idf)%n_hax = phid 862 W_F(idf)%hax_name(phid,1:2) = (/ lon_name,lat_name /) 867 863 tmp_title = phtitle 868 864 !- … … 949 945 END SUBROUTINE histhori_irregular 950 946 !=== 951 SUBROUTINE histvert ( pfileid,pzaxname,pzaxtitle,pzaxunit, &947 SUBROUTINE histvert (idf,pzaxname,pzaxtitle,pzaxunit, & 952 948 & pzsize,pzvalues,pzaxid,pdirect) 953 949 !--------------------------------------------------------------------- … … 959 955 !- INPUT 960 956 !- 961 !- pfileid: ID of the file the variable should be archived in957 !- idf : ID of the file the variable should be archived in 962 958 !- pzaxname : Name of the vertical axis 963 959 !- pzaxtitle: title of the vertical axis … … 978 974 IMPLICIT NONE 979 975 !- 980 INTEGER,INTENT(IN) :: pfileid,pzsize976 INTEGER,INTENT(IN) :: idf,pzsize 981 977 CHARACTER(LEN=*),INTENT(IN) :: pzaxname,pzaxunit,pzaxtitle 982 978 REAL,INTENT(IN) :: pzvalues(pzsize) … … 1022 1018 ENDIF 1023 1019 !- 1024 IF (W_F( pfileid)%n_zax+1 > nb_zax_max) THEN1020 IF (W_F(idf)%n_zax+1 > nb_zax_max) THEN 1025 1021 CALL ipslerr (3,"histvert", & 1026 1022 & 'Table of vertical axes too small. You should increase ',& … … 1029 1025 ENDIF 1030 1026 !- 1031 iv = W_F( pfileid)%n_zax1027 iv = W_F(idf)%n_zax 1032 1028 IF (iv > 1) THEN 1033 CALL find_str (W_F( pfileid)%zax_name(1:iv-1),pzaxname,pos)1029 CALL find_str (W_F(idf)%zax_name(1:iv-1),pzaxname,pos) 1034 1030 ELSE 1035 1031 pos = 0 … … 1038 1034 IF (pos > 0) THEN 1039 1035 WRITE(str71,'("Check variable ",A," in file",I3)') & 1040 & TRIM(pzaxname), pfileid1036 & TRIM(pzaxname),idf 1041 1037 CALL ipslerr (3,"histvert", & 1042 1038 & "Vertical axis already exists",TRIM(str71), & … … 1044 1040 ENDIF 1045 1041 !- 1046 iv = W_F( pfileid)%n_zax+11042 iv = W_F(idf)%n_zax+1 1047 1043 !- 1048 1044 ! 2.0 Add the information to the file … … 1051 1047 & WRITE(*,*) "histvert : 2.0 Add the information to the file" 1052 1048 !- 1053 nfid = W_F( pfileid)%ncfid1049 nfid = W_F(idf)%ncfid 1054 1050 !- 1055 1051 leng = MIN(LEN_TRIM(pzaxname),20) … … 1084 1080 & WRITE(*,*) "histvert : 3.0 add the information to the common" 1085 1081 !- 1086 W_F( pfileid)%n_zax = iv1087 W_F( pfileid)%zax_size(iv) = pzsize1088 W_F( pfileid)%zax_name(iv) = pzaxname1089 W_F( pfileid)%zax_ids(iv) = zaxid_tmp1082 W_F(idf)%n_zax = iv 1083 W_F(idf)%zax_size(iv) = pzsize 1084 W_F(idf)%zax_name(iv) = pzaxname 1085 W_F(idf)%zax_ids(iv) = zaxid_tmp 1090 1086 pzaxid = iv 1091 1087 !---------------------- … … 1093 1089 !=== 1094 1090 SUBROUTINE histdef & 1095 & ( pfileid,pvarname,ptitle,punit, &1091 & (idf,pvarname,ptitle,punit, & 1096 1092 & pxsize,pysize,phoriid,pzsize,par_oriz,par_szz,pzid, & 1097 1093 & xtype,popp,pfreq_opp,pfreq_wrt,var_range,standard_name) … … 1106 1102 !- INPUT 1107 1103 !- 1108 !- pfileid: ID of the file the variable should be archived in1104 !- idf : ID of the file the variable should be archived in 1109 1105 !- pvarname : Name of the variable, short and easy to remember 1110 1106 !- ptitle : Full name of the variable … … 1146 1142 IMPLICIT NONE 1147 1143 !- 1148 INTEGER,INTENT(IN) :: pfileid,pxsize,pysize,pzsize,pzid1144 INTEGER,INTENT(IN) :: idf,pxsize,pysize,pzsize,pzid 1149 1145 INTEGER,INTENT(IN) :: par_oriz,par_szz,xtype,phoriid 1150 1146 CHARACTER(LEN=*),INTENT(IN) :: pvarname,punit,popp,ptitle … … 1153 1149 CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: standard_name 1154 1150 !- 1155 INTEGER :: iv ,i1151 INTEGER :: iv 1156 1152 CHARACTER(LEN=70) :: str70,str71,str72 1157 1153 CHARACTER(LEN=20) :: tmp_name … … 1167 1163 ex_topps = 'ave, inst, t_min, t_max, t_sum, once, never, l_max, l_min' 1168 1164 !- 1169 W_F( pfileid)%n_var = W_F(pfileid)%n_var+11170 iv = W_F( pfileid)%n_var1165 W_F(idf)%n_var = W_F(idf)%n_var+1 1166 iv = W_F(idf)%n_var 1171 1167 !- 1172 1168 IF (iv > nb_var_max) THEN … … 1183 1179 !- 1184 1180 IF (iv > 1) THEN 1185 CALL find_str (W_F( pfileid)%W_V(1:iv-1)%v_name,pvarname,pos)1181 CALL find_str (W_F(idf)%W_V(1:iv-1)%v_name,pvarname,pos) 1186 1182 ELSE 1187 1183 pos = 0 … … 1191 1187 str70 = "Variable already exists" 1192 1188 WRITE(str71,'("Check variable ",a," in file",I3)') & 1193 & TRIM(pvarname), pfileid1189 & TRIM(pvarname),idf 1194 1190 str72 = "Can also be a wrong file ID in another declaration" 1195 1191 CALL ipslerr (3,"histdef",str70,str71,str72) 1196 1192 ENDIF 1197 1193 !- 1198 W_F( pfileid)%W_V(iv)%v_name = pvarname1199 W_F( pfileid)%W_V(iv)%title = ptitle1200 W_F( pfileid)%W_V(iv)%unit_name = punit1194 W_F(idf)%W_V(iv)%v_name = pvarname 1195 W_F(idf)%W_V(iv)%title = ptitle 1196 W_F(idf)%W_V(iv)%unit_name = punit 1201 1197 IF (PRESENT(standard_name)) THEN 1202 W_F( pfileid)%W_V(iv)%std_name = standard_name1203 ELSE 1204 W_F( pfileid)%W_V(iv)%std_name = ptitle1205 ENDIF 1206 tmp_name = W_F( pfileid)%W_V(iv)%v_name1198 W_F(idf)%W_V(iv)%std_name = standard_name 1199 ELSE 1200 W_F(idf)%W_V(iv)%std_name = ptitle 1201 ENDIF 1202 tmp_name = W_F(idf)%W_V(iv)%v_name 1207 1203 !- 1208 1204 ! 1.1 decode the operations 1209 1205 !- 1210 W_F( pfileid)%W_V(iv)%fullop = popp1206 W_F(idf)%W_V(iv)%fullop = popp 1211 1207 CALL buildop & 1212 & (TRIM(popp),ex_topps,W_F( pfileid)%W_V(iv)%topp,missing_val, &1213 & W_F( pfileid)%W_V(iv)%sopp,W_F(pfileid)%W_V(iv)%scal, &1214 & W_F( pfileid)%W_V(iv)%nbopp)1208 & (TRIM(popp),ex_topps,W_F(idf)%W_V(iv)%topp,missing_val, & 1209 & W_F(idf)%W_V(iv)%sopp,W_F(idf)%W_V(iv)%scal, & 1210 & W_F(idf)%W_V(iv)%nbopp) 1215 1211 !- 1216 1212 ! 1.2 If we have an even number of operations 1217 1213 ! then we need to add identity 1218 1214 !- 1219 IF ( MOD(W_F( pfileid)%W_V(iv)%nbopp,2) == 0) THEN1220 W_F( pfileid)%W_V(iv)%nbopp = W_F(pfileid)%W_V(iv)%nbopp+11221 W_F( pfileid)%W_V(iv)%sopp(W_F(pfileid)%W_V(iv)%nbopp) = 'ident'1222 W_F( pfileid)%W_V(iv)%scal(W_F(pfileid)%W_V(iv)%nbopp) = missing_val1215 IF ( MOD(W_F(idf)%W_V(iv)%nbopp,2) == 0) THEN 1216 W_F(idf)%W_V(iv)%nbopp = W_F(idf)%W_V(iv)%nbopp+1 1217 W_F(idf)%W_V(iv)%sopp(W_F(idf)%W_V(iv)%nbopp) = 'ident' 1218 W_F(idf)%W_V(iv)%scal(W_F(idf)%W_V(iv)%nbopp) = missing_val 1223 1219 ENDIF 1224 1220 !- … … 1226 1222 !- 1227 1223 IF (xtype == hist_r8) THEN 1228 W_F( pfileid)%W_V(iv)%v_typ = hist_r81229 ELSE 1230 W_F( pfileid)%W_V(iv)%v_typ = hist_r41224 W_F(idf)%W_V(iv)%v_typ = hist_r8 1225 ELSE 1226 W_F(idf)%W_V(iv)%v_typ = hist_r4 1231 1227 ENDIF 1232 1228 !- … … 1234 1230 !- 1235 1231 IF (l_dbg) THEN 1236 WRITE(*,*) "histdef : 2.0", pfileid,iv,W_F(pfileid)%W_V(iv)%nbopp, &1237 & W_F( pfileid)%W_V(iv)%sopp(1:W_F(pfileid)%W_V(iv)%nbopp), &1238 & W_F( pfileid)%W_V(iv)%scal(1:W_F(pfileid)%W_V(iv)%nbopp)1239 ENDIF 1240 !- 1241 W_F( pfileid)%W_V(iv)%scsize(1:3) = (/ pxsize,pysize,pzsize /)1242 W_F( pfileid)%W_V(iv)%zorig(1:3) = &1243 & (/ W_F( pfileid)%slab_ori(1),W_F(pfileid)%slab_ori(2),par_oriz /)1244 W_F( pfileid)%W_V(iv)%zsize(1:3) = &1245 & (/ W_F( pfileid)%slab_sz(1),W_F(pfileid)%slab_sz(2),par_szz /)1232 WRITE(*,*) "histdef : 2.0",idf,iv,W_F(idf)%W_V(iv)%nbopp, & 1233 & W_F(idf)%W_V(iv)%sopp(1:W_F(idf)%W_V(iv)%nbopp), & 1234 & W_F(idf)%W_V(iv)%scal(1:W_F(idf)%W_V(iv)%nbopp) 1235 ENDIF 1236 !- 1237 W_F(idf)%W_V(iv)%scsize(1:3) = (/ pxsize,pysize,pzsize /) 1238 W_F(idf)%W_V(iv)%zorig(1:3) = & 1239 & (/ W_F(idf)%slab_ori(1),W_F(idf)%slab_ori(2),par_oriz /) 1240 W_F(idf)%W_V(iv)%zsize(1:3) = & 1241 & (/ W_F(idf)%slab_sz(1),W_F(idf)%slab_sz(2),par_szz /) 1246 1242 !- 1247 1243 ! Is the size of the full array the same as that of the coordinates ? 1248 1244 !- 1249 IF ( (pxsize > W_F( pfileid)%full_size(1)) &1250 & .OR.(pysize > W_F( pfileid)%full_size(2)) ) THEN1245 IF ( (pxsize > W_F(idf)%full_size(1)) & 1246 & .OR.(pysize > W_F(idf)%full_size(2)) ) THEN 1251 1247 !- 1252 1248 str70 = "The size of the variable is different "// & 1253 1249 & "from the one of the coordinates" 1254 1250 WRITE(str71,'("Size of coordinates :",2I4)') & 1255 & W_F( pfileid)%full_size(1),W_F(pfileid)%full_size(2)1251 & W_F(idf)%full_size(1),W_F(idf)%full_size(2) 1256 1252 WRITE(str72,'("Size declared for variable ",a," :",2I4)') & 1257 1253 & TRIM(tmp_name),pxsize,pysize … … 1261 1257 ! Is the size of the zoom smaller than the coordinates ? 1262 1258 !- 1263 IF ( (W_F( pfileid)%full_size(1) < W_F(pfileid)%slab_sz(1)) &1264 & .OR.(W_F( pfileid)%full_size(2) < W_F(pfileid)%slab_sz(2)) ) THEN1259 IF ( (W_F(idf)%full_size(1) < W_F(idf)%slab_sz(1)) & 1260 & .OR.(W_F(idf)%full_size(2) < W_F(idf)%slab_sz(2)) ) THEN 1265 1261 str70 = & 1266 1262 & "Size of variable should be greater or equal to those of the zoom" 1267 1263 WRITE(str71,'("Size of XY zoom :",2I4)') & 1268 & W_F( pfileid)%slab_sz(1),W_F(pfileid)%slab_sz(2)1264 & W_F(idf)%slab_sz(1),W_F(idf)%slab_sz(2) 1269 1265 WRITE(str72,'("Size declared for variable ",A," :",2I4)') & 1270 1266 & TRIM(tmp_name),pxsize,pysize … … 1275 1271 ! and a fall back onto the default grid 1276 1272 !- 1277 IF ( (phoriid > 0).AND.(phoriid <= W_F( pfileid)%n_hax) ) THEN1278 W_F( pfileid)%W_V(iv)%h_axid = phoriid1279 ELSE 1280 W_F( pfileid)%W_V(iv)%h_axid = 11273 IF ( (phoriid > 0).AND.(phoriid <= W_F(idf)%n_hax) ) THEN 1274 W_F(idf)%W_V(iv)%h_axid = phoriid 1275 ELSE 1276 W_F(idf)%W_V(iv)%h_axid = 1 1281 1277 CALL ipslerr (2,"histdef", & 1282 1278 & 'We use the default grid for variable as an invalide',& … … 1290 1286 !-- Does the vertical coordinate exist ? 1291 1287 !- 1292 IF (pzid > W_F( pfileid)%n_zax) THEN1288 IF (pzid > W_F(idf)%n_zax) THEN 1293 1289 WRITE(str70, & 1294 1290 & '("The vertical coordinate chosen for variable ",a)') & … … 1300 1296 !-- Is the vertical size of the variable equal to that of the axis ? 1301 1297 !- 1302 IF (par_szz /= W_F( pfileid)%zax_size(pzid)) THEN1298 IF (par_szz /= W_F(idf)%zax_size(pzid)) THEN 1303 1299 str70 = "The size of the zoom does not correspond "// & 1304 1300 & "to the size of the chosen vertical axis" 1305 1301 WRITE(str71,'("Size of zoom in z :",I4)') par_szz 1306 1302 WRITE(str72,'("Size declared for axis ",A," :",I4)') & 1307 & TRIM(W_F( pfileid)%zax_name(pzid)),W_F(pfileid)%zax_size(pzid)1303 & TRIM(W_F(idf)%zax_name(pzid)),W_F(idf)%zax_size(pzid) 1308 1304 CALL ipslerr (3,"histdef",str70,str71,str72) 1309 1305 ENDIF … … 1319 1315 CALL ipslerr (3,"histdef",str70,str71,str72) 1320 1316 ENDIF 1321 W_F(pfileid)%W_V(iv)%z_axid = pzid 1322 ELSE 1323 W_F(pfileid)%W_V(iv)%z_axid = -99 1324 ENDIF 1325 !- 1326 ! 3.0 Determine the position of the variable in the buffer 1327 ! If it is instantaneous output then we do not use the buffer 1328 !- 1329 IF (l_dbg) WRITE(*,*) "histdef : 3.0" 1330 !- 1331 ! 3.1 We get the size of the arrays histwrite will get and check 1332 ! that they fit into the tmp_buffer 1333 !- 1334 buff_sz = W_F(pfileid)%W_V(iv)%zsize(1) & 1335 & *W_F(pfileid)%W_V(iv)%zsize(2) & 1336 & *W_F(pfileid)%W_V(iv)%zsize(3) 1337 !- 1338 ! 3.2 move the pointer of the buffer array for operation 1339 ! which need bufferisation 1340 !- 1341 IF ( (TRIM(W_F(pfileid)%W_V(iv)%topp) /= "inst") & 1342 & .AND.(TRIM(W_F(pfileid)%W_V(iv)%topp) /= "once") & 1343 & .AND.(TRIM(W_F(pfileid)%W_V(iv)%topp) /= "never") )THEN 1344 W_F(pfileid)%W_V(iv)%point = buff_pos+1 1345 buff_pos = buff_pos+buff_sz 1317 W_F(idf)%W_V(iv)%z_axid = pzid 1318 ELSE 1319 W_F(idf)%W_V(iv)%z_axid = -99 1320 ENDIF 1321 !- 1322 ! 3.0 We get the size of the arrays histwrite will get 1323 ! and eventually allocate the time_buffer 1324 !- 1325 IF (l_dbg) THEN 1326 WRITE(*,*) "histdef : 3.0" 1327 ENDIF 1328 !- 1329 buff_sz = W_F(idf)%W_V(iv)%zsize(1) & 1330 & *W_F(idf)%W_V(iv)%zsize(2) & 1331 & *W_F(idf)%W_V(iv)%zsize(3) 1332 !- 1333 IF ( (TRIM(W_F(idf)%W_V(iv)%topp) /= "inst") & 1334 & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "once") & 1335 & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "never") )THEN 1336 ALLOCATE(W_F(idf)%W_V(iv)%t_bf(buff_sz)) 1337 W_F(idf)%W_V(iv)%t_bf(:) = 0. 1346 1338 IF (l_dbg) THEN 1347 WRITE(*,*) "histdef : 3. 2 bufpos for iv = ",iv, &1348 & " pfileid = ",pfileid," is = ",W_F(pfileid)%W_V(iv)%point1339 WRITE(*,*) "histdef : 3.0 allocating time_buffer for", & 1340 & " idf = ",idf," iv = ",iv," size = ",buff_sz 1349 1341 ENDIF 1350 1342 ENDIF … … 1357 1349 IF (l_dbg) WRITE(*,*) "histdef : 4.0" 1358 1350 !- 1359 W_F( pfileid)%W_V(iv)%freq_opp = pfreq_opp1360 W_F( pfileid)%W_V(iv)%freq_wrt = pfreq_wrt1351 W_F(idf)%W_V(iv)%freq_opp = pfreq_opp 1352 W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt 1361 1353 !- 1362 1354 CALL ioget_calendar(un_an,un_jour) … … 1376 1368 ! 4.1 Frequency of operations and output should be larger than deltat ! 1377 1369 !- 1378 IF (test_fopp < W_F( pfileid)%deltat) THEN1370 IF (test_fopp < W_F(idf)%deltat) THEN 1379 1371 str70 = 'Frequency of operations should be larger than deltat' 1380 1372 WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') & … … 1384 1376 CALL ipslerr (2,"histdef",str70,str71,str72) 1385 1377 !- 1386 W_F( pfileid)%W_V(iv)%freq_opp = W_F(pfileid)%deltat1387 ENDIF 1388 !- 1389 IF (test_fwrt < W_F( pfileid)%deltat) THEN1378 W_F(idf)%W_V(iv)%freq_opp = W_F(idf)%deltat 1379 ENDIF 1380 !- 1381 IF (test_fwrt < W_F(idf)%deltat) THEN 1390 1382 str70 = 'Frequency of output should be larger than deltat' 1391 1383 WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') & … … 1395 1387 CALL ipslerr (2,"histdef",str70,str71,str72) 1396 1388 !- 1397 W_F( pfileid)%W_V(iv)%freq_wrt = W_F(pfileid)%deltat1389 W_F(idf)%W_V(iv)%freq_wrt = W_F(idf)%deltat 1398 1390 ENDIF 1399 1391 !- … … 1401 1393 ! its compaticility with the choice of frequencies 1402 1394 !- 1403 IF (TRIM(W_F( pfileid)%W_V(iv)%topp) == "inst") THEN1395 IF (TRIM(W_F(idf)%W_V(iv)%topp) == "inst") THEN 1404 1396 IF (test_fopp /= test_fwrt) THEN 1405 1397 str70 = 'For instantaneous output the frequency '// & … … 1411 1403 CALL ipslerr (2,"histdef",str70,str71,str72) 1412 1404 IF (test_fopp < test_fwrt) THEN 1413 W_F( pfileid)%W_V(iv)%freq_opp = pfreq_opp1414 W_F( pfileid)%W_V(iv)%freq_wrt = pfreq_opp1405 W_F(idf)%W_V(iv)%freq_opp = pfreq_opp 1406 W_F(idf)%W_V(iv)%freq_wrt = pfreq_opp 1415 1407 ELSE 1416 W_F( pfileid)%W_V(iv)%freq_opp = pfreq_wrt1417 W_F( pfileid)%W_V(iv)%freq_wrt = pfreq_wrt1408 W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt 1409 W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt 1418 1410 ENDIF 1419 1411 ENDIF 1420 ELSE IF (INDEX(ex_topps,TRIM(W_F( pfileid)%W_V(iv)%topp)) > 0) THEN1412 ELSE IF (INDEX(ex_topps,TRIM(W_F(idf)%W_V(iv)%topp)) > 0) THEN 1421 1413 IF (test_fopp > test_fwrt) THEN 1422 1414 str70 = 'For averages the frequency of operations '// & … … 1427 1419 str72 = 'PATCH : The output frequency is used for both' 1428 1420 CALL ipslerr (2,"histdef",str70,str71,str72) 1429 W_F( pfileid)%W_V(iv)%freq_opp = pfreq_wrt1421 W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt 1430 1422 ENDIF 1431 1423 ELSE … … 1433 1425 & TRIM(tmp_name) 1434 1426 WRITE (str71,'("operation requested is :",A)') & 1435 & W_F( pfileid)%W_V(iv)%topp1436 WRITE (str72,'("File ID :",I3)') pfileid1427 & W_F(idf)%W_V(iv)%topp 1428 WRITE (str72,'("File ID :",I3)') idf 1437 1429 CALL ipslerr (3,"histdef",str70,str71,str72) 1438 1430 ENDIF … … 1442 1434 IF (l_dbg) WRITE(*,*) "histdef : 5.0" 1443 1435 !- 1444 W_F( pfileid)%W_V(iv)%hist_wrt_rng = (PRESENT(var_range))1445 IF (W_F( pfileid)%W_V(iv)%hist_wrt_rng) THEN1446 W_F( pfileid)%W_V(iv)%hist_calc_rng = (var_range(1) > var_range(2))1447 IF (W_F( pfileid)%W_V(iv)%hist_calc_rng) THEN1448 W_F( pfileid)%W_V(iv)%hist_minmax(1:2) = &1436 W_F(idf)%W_V(iv)%hist_wrt_rng = (PRESENT(var_range)) 1437 IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN 1438 W_F(idf)%W_V(iv)%hist_calc_rng = (var_range(1) > var_range(2)) 1439 IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN 1440 W_F(idf)%W_V(iv)%hist_minmax(1:2) = & 1449 1441 & (/ ABS(missing_val),-ABS(missing_val) /) 1450 1442 ELSE 1451 W_F( pfileid)%W_V(iv)%hist_minmax(1:2) = var_range(1:2)1452 ENDIF 1453 ENDIF 1454 !- 1455 ! - freq_opp( pfileid,iv)/2./deltat(pfileid)1456 W_F( pfileid)%W_V(iv)%last_opp = W_F(pfileid)%itau01457 ! - freq_wrt( pfileid,iv)/2./deltat(pfileid)1458 W_F( pfileid)%W_V(iv)%last_wrt = W_F(pfileid)%itau01459 ! - freq_opp( pfileid,iv)/2./deltat(pfileid)1460 W_F( pfileid)%W_V(iv)%last_opp_chk = W_F(pfileid)%itau01461 ! - freq_wrt( pfileid,iv)/2./deltat(pfileid)1462 W_F( pfileid)%W_V(iv)%last_wrt_chk = W_F(pfileid)%itau01463 W_F( pfileid)%W_V(iv)%nb_opp = 01464 W_F( pfileid)%W_V(iv)%nb_wrt = 01443 W_F(idf)%W_V(iv)%hist_minmax(1:2) = var_range(1:2) 1444 ENDIF 1445 ENDIF 1446 !- 1447 ! - freq_opp(idf,iv)/2./deltat(idf) 1448 W_F(idf)%W_V(iv)%last_opp = W_F(idf)%itau0 1449 ! - freq_wrt(idf,iv)/2./deltat(idf) 1450 W_F(idf)%W_V(iv)%last_wrt = W_F(idf)%itau0 1451 ! - freq_opp(idf,iv)/2./deltat(idf) 1452 W_F(idf)%W_V(iv)%last_opp_chk = W_F(idf)%itau0 1453 ! - freq_wrt(idf,iv)/2./deltat(idf) 1454 W_F(idf)%W_V(iv)%last_wrt_chk = W_F(idf)%itau0 1455 W_F(idf)%W_V(iv)%nb_opp = 0 1456 W_F(idf)%W_V(iv)%nb_wrt = 0 1465 1457 !- 1466 1458 ! 6.0 Get the time axis for this variable … … 1468 1460 IF (l_dbg) WRITE(*,*) "histdef : 6.0" 1469 1461 !- 1470 IF (W_F( pfileid)%W_V(iv)%freq_wrt > 0) THEN1471 WRITE(str10,'(I8.8)') INT(W_F( pfileid)%W_V(iv)%freq_wrt)1472 str40 = TRIM(W_F( pfileid)%W_V(iv)%topp)//"_"//TRIM(str10)1473 ELSE 1474 WRITE(str10,'(I2.2,"month")') ABS(INT(W_F( pfileid)%W_V(iv)%freq_wrt))1475 str40 = TRIM(W_F( pfileid)%W_V(iv)%topp)//"_"//TRIM(str10)1476 ENDIF 1477 CALL find_str (W_F( pfileid)%W_V(1:W_F(pfileid)%n_tax)%tax_name,str40,pos)1462 IF (W_F(idf)%W_V(iv)%freq_wrt > 0) THEN 1463 WRITE(str10,'(I8.8)') INT(W_F(idf)%W_V(iv)%freq_wrt) 1464 str40 = TRIM(W_F(idf)%W_V(iv)%topp)//"_"//TRIM(str10) 1465 ELSE 1466 WRITE(str10,'(I2.2,"month")') ABS(INT(W_F(idf)%W_V(iv)%freq_wrt)) 1467 str40 = TRIM(W_F(idf)%W_V(iv)%topp)//"_"//TRIM(str10) 1468 ENDIF 1469 CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_tax)%tax_name,str40,pos) 1478 1470 !- 1479 1471 ! No time axis for once, l_max, l_min or never operation 1480 1472 !- 1481 IF ( (TRIM(W_F( pfileid)%W_V(iv)%topp) /= 'once') &1482 & .AND.(TRIM(W_F( pfileid)%W_V(iv)%topp) /= 'never') &1483 & .AND.(TRIM(W_F( pfileid)%W_V(iv)%topp) /= 'l_max') &1484 & .AND.(TRIM(W_F( pfileid)%W_V(iv)%topp) /= 'l_min') ) THEN1473 IF ( (TRIM(W_F(idf)%W_V(iv)%topp) /= 'once') & 1474 & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'never') & 1475 & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_max') & 1476 & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_min') ) THEN 1485 1477 IF (pos < 0) THEN 1486 W_F( pfileid)%n_tax = W_F(pfileid)%n_tax+11487 W_F( pfileid)%W_V(W_F(pfileid)%n_tax)%tax_name = str401488 W_F( pfileid)%W_V(W_F(pfileid)%n_tax)%tax_last = 01489 W_F( pfileid)%W_V(iv)%t_axid = W_F(pfileid)%n_tax1478 W_F(idf)%n_tax = W_F(idf)%n_tax+1 1479 W_F(idf)%W_V(W_F(idf)%n_tax)%tax_name = str40 1480 W_F(idf)%W_V(W_F(idf)%n_tax)%tax_last = 0 1481 W_F(idf)%W_V(iv)%t_axid = W_F(idf)%n_tax 1490 1482 ELSE 1491 W_F( pfileid)%W_V(iv)%t_axid = pos1483 W_F(idf)%W_V(iv)%t_axid = pos 1492 1484 ENDIF 1493 1485 ELSE 1494 1486 IF (l_dbg) THEN 1495 WRITE(*,*) "histdef : 7.0 ",TRIM(W_F( pfileid)%W_V(iv)%topp),'----'1496 ENDIF 1497 W_F( pfileid)%W_V(iv)%t_axid = -991487 WRITE(*,*) "histdef : 7.0 ",TRIM(W_F(idf)%W_V(iv)%topp),'----' 1488 ENDIF 1489 W_F(idf)%W_V(iv)%t_axid = -99 1498 1490 ENDIF 1499 1491 !- … … 1501 1493 ! for never or once operation 1502 1494 !- 1503 IF ( (TRIM(W_F( pfileid)%W_V(iv)%topp) == 'once') &1504 & .OR.(TRIM(W_F( pfileid)%W_V(iv)%topp) == 'never') ) THEN1505 W_F( pfileid)%W_V(iv)%freq_opp = 0.1506 W_F( pfileid)%W_V(iv)%freq_wrt = 0.1495 IF ( (TRIM(W_F(idf)%W_V(iv)%topp) == 'once') & 1496 & .OR.(TRIM(W_F(idf)%W_V(iv)%topp) == 'never') ) THEN 1497 W_F(idf)%W_V(iv)%freq_opp = 0. 1498 W_F(idf)%W_V(iv)%freq_wrt = 0. 1507 1499 ENDIF 1508 1500 !--------------------- 1509 1501 END SUBROUTINE histdef 1510 1502 !=== 1511 SUBROUTINE histend ( pfileid)1503 SUBROUTINE histend (idf) 1512 1504 !--------------------------------------------------------------------- 1513 1505 !- This subroutine end the decalaration of variables and sets the … … 1516 1508 !- INPUT 1517 1509 !- 1518 !- pfileid: ID of the file to be worked on1510 !- idf : ID of the file to be worked on 1519 1511 !- 1520 1512 !- VERSION … … 1523 1515 IMPLICIT NONE 1524 1516 !- 1525 INTEGER,INTENT(IN) :: pfileid1517 INTEGER,INTENT(IN) :: idf 1526 1518 !- 1527 1519 INTEGER :: nfid,nvid,iret,ndim,iv,itx,ziv,itax,dim_cnt … … 1541 1533 CALL ipsldbg (old_status=l_dbg) 1542 1534 !- 1543 nfid = W_F( pfileid)%ncfid1535 nfid = W_F(idf)%ncfid 1544 1536 !- 1545 1537 ! 1.0 Create the time axes … … 1548 1540 !--- 1549 1541 iret = NF90_DEF_DIM (nfid,'time_counter', & 1550 & NF90_UNLIMITED,W_F( pfileid)%tid)1542 & NF90_UNLIMITED,W_F(idf)%tid) 1551 1543 !- 1552 1544 ! 1.1 Define all the time axes needed for this file 1553 1545 !- 1554 DO itx=1,W_F( pfileid)%n_tax1555 dims(1) = W_F( pfileid)%tid1556 IF (W_F( pfileid)%n_tax > 1) THEN1557 str30 = "t_"//W_F( pfileid)%W_V(itx)%tax_name1546 DO itx=1,W_F(idf)%n_tax 1547 dims(1) = W_F(idf)%tid 1548 IF (W_F(idf)%n_tax > 1) THEN 1549 str30 = "t_"//W_F(idf)%W_V(itx)%tax_name 1558 1550 ELSE 1559 1551 str30 = "time_counter" 1560 1552 ENDIF 1561 1553 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) THEN1564 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, &1554 & dims(1),W_F(idf)%W_V(itx)%tdimid) 1555 IF (W_F(idf)%n_tax <= 1) THEN 1556 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid,'axis',"T") 1557 ENDIF 1558 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1567 1559 & 'standard_name',"time") 1568 1560 !--- … … 1573 1565 ! if there is a ioconf routine to control it. 1574 1566 !--- 1575 !-- rtime0 = itau2date(itau0( pfileid),date0(pfileid),deltat(pfileid))1576 rtime0 = W_F( pfileid)%date01567 !-- rtime0 = itau2date(itau0(idf),date0(idf),deltat(idf)) 1568 rtime0 = W_F(idf)%date0 1577 1569 !- 1578 1570 CALL ju2ymds(rtime0,year,month,day,sec) … … 1591 1583 & FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & 1592 1584 & 'seconds since ',year,month,day,hours,minutes,INT(sec) 1593 iret = NF90_PUT_ATT (nfid,W_F( pfileid)%W_V(itx)%tdimid, &1585 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1594 1586 & 'units',TRIM(str70)) 1595 1587 !- 1596 1588 CALL ioget_calendar (str30) 1597 iret = NF90_PUT_ATT (nfid,W_F( pfileid)%W_V(itx)%tdimid, &1589 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1598 1590 & 'calendar',TRIM(str30)) 1599 1591 !- 1600 iret = NF90_PUT_ATT (nfid,W_F( pfileid)%W_V(itx)%tdimid, &1592 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1601 1593 & 'title','Time') 1602 1594 !- 1603 iret = NF90_PUT_ATT (nfid,W_F( pfileid)%W_V(itx)%tdimid, &1595 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1604 1596 & 'long_name','Time axis') 1605 1597 !- … … 1607 1599 & FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & 1608 1600 & year,cal(month),day,hours,minutes,INT(sec) 1609 iret = NF90_PUT_ATT (nfid,W_F( pfileid)%W_V(itx)%tdimid, &1601 iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & 1610 1602 & 'time_origin',TRIM(str70)) 1611 1603 ENDDO … … 1615 1607 IF (l_dbg) WRITE(*,*) "histend : 2.0" 1616 1608 !- 1617 DO iv=1,W_F( pfileid)%n_var1609 DO iv=1,W_F(idf)%n_var 1618 1610 !--- 1619 itax = W_F( pfileid)%W_V(iv)%t_axid1611 itax = W_F(idf)%W_V(iv)%t_axid 1620 1612 !--- 1621 IF (W_F( pfileid)%regular) THEN1622 dims(1:2) = (/ W_F( pfileid)%xid,W_F(pfileid)%yid /)1613 IF (W_F(idf)%regular) THEN 1614 dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /) 1623 1615 dim_cnt = 2 1624 1616 ELSE 1625 dims(1) = W_F( pfileid)%xid1617 dims(1) = W_F(idf)%xid 1626 1618 dim_cnt = 1 1627 1619 ENDIF 1628 1620 !--- 1629 tmp_opp = W_F( pfileid)%W_V(iv)%topp1630 ziv = W_F( pfileid)%W_V(iv)%z_axid1621 tmp_opp = W_F(idf)%W_V(iv)%topp 1622 ziv = W_F(idf)%W_V(iv)%z_axid 1631 1623 !--- 1632 1624 ! 2.1 dimension of field … … 1638 1630 IF (ziv == -99) THEN 1639 1631 ndim = dim_cnt+1 1640 dims(dim_cnt+1:dim_cnt+2) = (/ W_F( pfileid)%tid,0 /)1632 dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%tid,0 /) 1641 1633 ELSE 1642 1634 ndim = dim_cnt+2 1643 1635 dims(dim_cnt+1:dim_cnt+2) = & 1644 & (/ W_F( pfileid)%zax_ids(ziv),W_F(pfileid)%tid /)1636 & (/ W_F(idf)%zax_ids(ziv),W_F(idf)%tid /) 1645 1637 ENDIF 1646 1638 ELSE … … 1650 1642 ELSE 1651 1643 ndim = dim_cnt+1 1652 dims(dim_cnt+1:dim_cnt+2) = (/ W_F( pfileid)%zax_ids(ziv),0 /)1644 dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%zax_ids(ziv),0 /) 1653 1645 ENDIF 1654 1646 ENDIF 1655 1647 !- 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 = nvid1660 !- 1661 IF (LEN_TRIM(W_F( pfileid)%W_V(iv)%unit_name) > 0) THEN1648 iret = NF90_DEF_VAR (nfid,TRIM(W_F(idf)%W_V(iv)%v_name), & 1649 & W_F(idf)%W_V(iv)%v_typ,dims(1:ABS(ndim)),nvid) 1650 !- 1651 W_F(idf)%W_V(iv)%ncvid = nvid 1652 !- 1653 IF (LEN_TRIM(W_F(idf)%W_V(iv)%unit_name) > 0) THEN 1662 1654 iret = NF90_PUT_ATT (nfid,nvid,'units', & 1663 & TRIM(W_F( pfileid)%W_V(iv)%unit_name))1655 & TRIM(W_F(idf)%W_V(iv)%unit_name)) 1664 1656 ENDIF 1665 1657 iret = NF90_PUT_ATT (nfid,nvid,'standard_name', & 1666 & TRIM(W_F( pfileid)%W_V(iv)%std_name))1658 & TRIM(W_F(idf)%W_V(iv)%std_name)) 1667 1659 !- 1668 1660 iret = NF90_PUT_ATT (nfid,nvid,'_FillValue', & 1669 1661 & REAL(missing_val,KIND=4)) 1670 IF (W_F( pfileid)%W_V(iv)%hist_wrt_rng) THEN1662 IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN 1671 1663 iret = NF90_PUT_ATT (nfid,nvid,'valid_min', & 1672 & REAL(W_F( pfileid)%W_V(iv)%hist_minmax(1),KIND=4))1664 & REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=4)) 1673 1665 iret = NF90_PUT_ATT (nfid,nvid,'valid_max', & 1674 & REAL(W_F( pfileid)%W_V(iv)%hist_minmax(2),KIND=4))1666 & REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=4)) 1675 1667 ENDIF 1676 1668 iret = NF90_PUT_ATT (nfid,nvid,'long_name', & 1677 & TRIM(W_F( pfileid)%W_V(iv)%title))1669 & TRIM(W_F(idf)%W_V(iv)%title)) 1678 1670 iret = NF90_PUT_ATT (nfid,nvid,'online_operation', & 1679 & TRIM(W_F( pfileid)%W_V(iv)%fullop))1671 & TRIM(W_F(idf)%W_V(iv)%fullop)) 1680 1672 !- 1681 1673 SELECT CASE(ndim) … … 1687 1679 END SELECT 1688 1680 !- 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_axid1681 assoc=TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,2)) & 1682 & //' '//TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,1)) 1683 !- 1684 ziv = W_F(idf)%W_V(iv)%z_axid 1693 1685 IF (ziv > 0) THEN 1694 str30 = W_F( pfileid)%zax_name(ziv)1686 str30 = W_F(idf)%zax_name(ziv) 1695 1687 assoc = TRIM(str30)//' '//TRIM(assoc) 1696 1688 ENDIF 1697 1689 !- 1698 1690 IF (itax > 0) THEN 1699 IF (W_F( pfileid)%n_tax > 1) THEN1700 str30 = "t_"//W_F( pfileid)%W_V(itax)%tax_name1691 IF (W_F(idf)%n_tax > 1) THEN 1692 str30 = "t_"//W_F(idf)%W_V(itax)%tax_name 1701 1693 ELSE 1702 1694 str30 = "time_counter" … … 1706 1698 IF (l_dbg) THEN 1707 1699 WRITE(*,*) "histend : 2.0.n, freq_opp, freq_wrt", & 1708 & W_F( pfileid)%W_V(iv)%freq_opp,W_F(pfileid)%W_V(iv)%freq_wrt1700 & W_F(idf)%W_V(iv)%freq_opp,W_F(idf)%W_V(iv)%freq_wrt 1709 1701 ENDIF 1710 1702 !- 1711 1703 iret = NF90_PUT_ATT (nfid,nvid,'interval_operation', & 1712 & REAL(W_F( pfileid)%W_V(iv)%freq_opp,KIND=4))1704 & REAL(W_F(idf)%W_V(iv)%freq_opp,KIND=4)) 1713 1705 iret = NF90_PUT_ATT (nfid,nvid,'interval_write', & 1714 & REAL(W_F( pfileid)%W_V(iv)%freq_wrt,KIND=4))1706 & REAL(W_F(idf)%W_V(iv)%freq_wrt,KIND=4)) 1715 1707 ENDIF 1716 1708 iret = NF90_PUT_ATT (nfid,nvid,'coordinates',TRIM(assoc)) … … 1720 1712 ! 2.2 Add DOMAIN attributes if needed 1721 1713 !- 1722 IF (W_F( pfileid)%dom_id_svg >= 0) THEN1723 CALL flio_dom_att (nfid,W_F( pfileid)%dom_id_svg)1714 IF (W_F(idf)%dom_id_svg >= 0) THEN 1715 CALL flio_dom_att (nfid,W_F(idf)%dom_id_svg) 1724 1716 ENDIF 1725 1717 !- … … 1734 1726 IF (l_dbg) WRITE(*,*) "histend : 4.0" 1735 1727 !- 1736 WRITE(str70,'("All variables have been initialized on file :",I3)') pfileid1728 WRITE(str70,'("All variables have been initialized on file :",I3)') idf 1737 1729 CALL ipslerr (1,'histend',str70,'',' ') 1738 1730 !--------------------- 1739 1731 END SUBROUTINE histend 1740 1732 !=== 1741 SUBROUTINE histwrite_r1d ( pfileid,pvarname,pitau,pdata,nbindex,nindex)1733 SUBROUTINE histwrite_r1d (idf,pvarname,pitau,pdata,nbindex,nindex) 1742 1734 !--------------------------------------------------------------------- 1743 1735 IMPLICIT NONE 1744 1736 !- 1745 INTEGER,INTENT(IN) :: pfileid,pitau,nbindex1737 INTEGER,INTENT(IN) :: idf,pitau,nbindex 1746 1738 INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex 1747 1739 REAL,DIMENSION(:),INTENT(IN) :: pdata 1748 1740 CHARACTER(LEN=*),INTENT(IN) :: pvarname 1749 1741 !--------------------------------------------------------------------- 1750 CALL histw_rnd ( pfileid,pvarname,pitau,nbindex,nindex,pdata_1d=pdata)1742 CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_1d=pdata) 1751 1743 !--------------------------- 1752 1744 END SUBROUTINE histwrite_r1d 1753 1745 !=== 1754 SUBROUTINE histwrite_r2d ( pfileid,pvarname,pitau,pdata,nbindex,nindex)1746 SUBROUTINE histwrite_r2d (idf,pvarname,pitau,pdata,nbindex,nindex) 1755 1747 !--------------------------------------------------------------------- 1756 1748 IMPLICIT NONE 1757 1749 !- 1758 INTEGER,INTENT(IN) :: pfileid,pitau,nbindex1750 INTEGER,INTENT(IN) :: idf,pitau,nbindex 1759 1751 INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex 1760 1752 REAL,DIMENSION(:,:),INTENT(IN) :: pdata 1761 1753 CHARACTER(LEN=*),INTENT(IN) :: pvarname 1762 1754 !--------------------------------------------------------------------- 1763 CALL histw_rnd ( pfileid,pvarname,pitau,nbindex,nindex,pdata_2d=pdata)1755 CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_2d=pdata) 1764 1756 !--------------------------- 1765 1757 END SUBROUTINE histwrite_r2d 1766 1758 !=== 1767 SUBROUTINE histwrite_r3d ( pfileid,pvarname,pitau,pdata,nbindex,nindex)1759 SUBROUTINE histwrite_r3d (idf,pvarname,pitau,pdata,nbindex,nindex) 1768 1760 !--------------------------------------------------------------------- 1769 1761 IMPLICIT NONE 1770 1762 !- 1771 INTEGER,INTENT(IN) :: pfileid,pitau,nbindex1763 INTEGER,INTENT(IN) :: idf,pitau,nbindex 1772 1764 INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex 1773 1765 REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata 1774 1766 CHARACTER(LEN=*),INTENT(IN) :: pvarname 1775 1767 !--------------------------------------------------------------------- 1776 CALL histw_rnd ( pfileid,pvarname,pitau,nbindex,nindex,pdata_3d=pdata)1768 CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_3d=pdata) 1777 1769 !--------------------------- 1778 1770 END SUBROUTINE histwrite_r3d 1779 1771 !=== 1780 SUBROUTINE histw_rnd ( pfileid,pvarname,pitau,nbindex,nindex, &1772 SUBROUTINE histw_rnd (idf,pvarname,pitau,nbindex,nindex, & 1781 1773 & pdata_1d,pdata_2d,pdata_3d) 1782 1774 !--------------------------------------------------------------------- 1783 1775 IMPLICIT NONE 1784 1776 !- 1785 INTEGER,INTENT(IN) :: pfileid,pitau,nbindex1777 INTEGER,INTENT(IN) :: idf,pitau,nbindex 1786 1778 INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex 1787 1779 CHARACTER(LEN=*),INTENT(IN) :: pvarname … … 1791 1783 !- 1792 1784 LOGICAL :: do_oper,do_write,largebuf,l1d,l2d,l3d 1793 INTEGER :: varid,io,nbpt_out1785 INTEGER :: iv,io,nbpt_out 1794 1786 INTEGER :: nbpt_in1 1795 1787 INTEGER,DIMENSION(2) :: nbpt_in2 1796 1788 INTEGER,DIMENSION(3) :: nbpt_in3 1797 REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buff_tmp 1798 INTEGER,SAVE :: buff_tmp_sz 1789 REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_1 1799 1790 CHARACTER(LEN=7) :: tmp_opp 1800 1791 CHARACTER(LEN=13) :: c_nam … … 1815 1806 ! Thanks Marine for showing us what errors users can make ! 1816 1807 !- 1817 IF ( ( pfileid < 1).OR.(pfileid> nb_files) ) THEN1808 IF ( (idf < 1).OR.(idf > nb_files) ) THEN 1818 1809 CALL ipslerr (3,"histwrite", & 1819 1810 & 'Illegal file ID in the histwrite of variable',pvarname,' ') … … 1822 1813 ! 1.1 Find the id of the variable to be written and the real time 1823 1814 !- 1824 CALL histvar_seq ( pfileid,pvarname,varid)1815 CALL histvar_seq (idf,pvarname,iv) 1825 1816 !- 1826 1817 ! 2.0 do nothing for never operation 1827 1818 !- 1828 tmp_opp = W_F( pfileid)%W_V(varid)%topp1819 tmp_opp = W_F(idf)%W_V(iv)%topp 1829 1820 !- 1830 1821 IF (TRIM(tmp_opp) == "never") THEN 1831 W_F( pfileid)%W_V(varid)%last_opp_chk = -991832 W_F( pfileid)%W_V(varid)%last_wrt_chk = -991822 W_F(idf)%W_V(iv)%last_opp_chk = -99 1823 W_F(idf)%W_V(iv)%last_wrt_chk = -99 1833 1824 ENDIF 1834 1825 !- 1835 1826 ! 3.0 We check if we need to do an operation 1836 1827 !- 1837 IF (W_F( pfileid)%W_V(varid)%last_opp_chk == pitau) THEN1828 IF (W_F(idf)%W_V(iv)%last_opp_chk == pitau) THEN 1838 1829 CALL ipslerr (3,"histwrite", & 1839 1830 & 'This variable has already been analysed at the present', & … … 1842 1833 !- 1843 1834 CALL isittime & 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)1835 & (pitau,W_F(idf)%date0,W_F(idf)%deltat, & 1836 & W_F(idf)%W_V(iv)%freq_opp, & 1837 & W_F(idf)%W_V(iv)%last_opp, & 1838 & W_F(idf)%W_V(iv)%last_opp_chk,do_oper) 1848 1839 !- 1849 1840 ! 4.0 We check if we need to write the data 1850 1841 !- 1851 IF (W_F( pfileid)%W_V(varid)%last_wrt_chk == pitau) THEN1842 IF (W_F(idf)%W_V(iv)%last_wrt_chk == pitau) THEN 1852 1843 CALL ipslerr (3,"histwrite", & 1853 1844 & 'This variable as already been written for the present', & … … 1856 1847 !- 1857 1848 CALL isittime & 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)1849 & (pitau,W_F(idf)%date0,W_F(idf)%deltat, & 1850 & W_F(idf)%W_V(iv)%freq_wrt, & 1851 & W_F(idf)%W_V(iv)%last_wrt, & 1852 & W_F(idf)%W_V(iv)%last_wrt_chk,do_write) 1862 1853 !- 1863 1854 ! 5.0 histwrite called … … 1867 1858 !-- 5.1 Get the sizes of the data we will handle 1868 1859 !- 1869 IF (W_F( pfileid)%W_V(varid)%datasz_in(1) <= 0) THEN1860 IF (W_F(idf)%W_V(iv)%datasz_in(1) <= 0) THEN 1870 1861 !---- There is the risk here that the user has over-sized the array. 1871 1862 !---- But how can we catch this ? 1872 1863 !---- In the worst case we will do impossible operations 1873 1864 !---- on part of the data ! 1874 W_F( pfileid)%W_V(varid)%datasz_in(1:3) = -11865 W_F(idf)%W_V(iv)%datasz_in(1:3) = -1 1875 1866 IF (l1d) THEN 1876 W_F( pfileid)%W_V(varid)%datasz_in(1) = SIZE(pdata_1d)1867 W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_1d) 1877 1868 ELSE IF (l2d) THEN 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)1869 W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_2d,DIM=1) 1870 W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_2d,DIM=2) 1880 1871 ELSE IF (l3d) THEN 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)1872 W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_3d,DIM=1) 1873 W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_3d,DIM=2) 1874 W_F(idf)%W_V(iv)%datasz_in(3) = SIZE(pdata_3d,DIM=3) 1884 1875 ENDIF 1885 1876 ENDIF … … 1887 1878 !-- 5.2 The maximum size of the data will give the size of the buffer 1888 1879 !- 1889 IF (W_F( pfileid)%W_V(varid)%datasz_max <= 0) THEN1880 IF (W_F(idf)%W_V(iv)%datasz_max <= 0) THEN 1890 1881 largebuf = .FALSE. 1891 DO io=1,W_F( pfileid)%W_V(varid)%nbopp1892 IF (INDEX(fuchnbout,W_F( pfileid)%W_V(varid)%sopp(io)) > 0) THEN1882 DO io=1,W_F(idf)%W_V(iv)%nbopp 1883 IF (INDEX(fuchnbout,W_F(idf)%W_V(iv)%sopp(io)) > 0) THEN 1893 1884 largebuf = .TRUE. 1894 1885 ENDIF 1895 1886 ENDDO 1896 1887 IF (largebuf) THEN 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)1888 W_F(idf)%W_V(iv)%datasz_max = & 1889 & W_F(idf)%W_V(iv)%scsize(1) & 1890 & *W_F(idf)%W_V(iv)%scsize(2) & 1891 & *W_F(idf)%W_V(iv)%scsize(3) 1901 1892 ELSE 1902 1893 IF (l1d) THEN 1903 W_F( pfileid)%W_V(varid)%datasz_max = &1904 & W_F( pfileid)%W_V(varid)%datasz_in(1)1894 W_F(idf)%W_V(iv)%datasz_max = & 1895 & W_F(idf)%W_V(iv)%datasz_in(1) 1905 1896 ELSE IF (l2d) THEN 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)1897 W_F(idf)%W_V(iv)%datasz_max = & 1898 & W_F(idf)%W_V(iv)%datasz_in(1) & 1899 & *W_F(idf)%W_V(iv)%datasz_in(2) 1909 1900 ELSE IF (l3d) THEN 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)1901 W_F(idf)%W_V(iv)%datasz_max = & 1902 & W_F(idf)%W_V(iv)%datasz_in(1) & 1903 & *W_F(idf)%W_V(iv)%datasz_in(2) & 1904 & *W_F(idf)%W_V(iv)%datasz_in(3) 1914 1905 ENDIF 1915 1906 ENDIF 1916 1907 ENDIF 1917 1908 !- 1918 IF (.NOT.ALLOCATED( buff_tmp)) THEN1909 IF (.NOT.ALLOCATED(tbf_1)) THEN 1919 1910 IF (l_dbg) THEN 1920 1911 WRITE(*,*) & 1921 & c_nam//" : allocate buff_tmp for buff_sz= ", &1922 & W_F( pfileid)%W_V(varid)%datasz_max1912 & c_nam//" : allocate tbf_1 for size = ", & 1913 & W_F(idf)%W_V(iv)%datasz_max 1923 1914 ENDIF 1924 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 1915 ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max)) 1916 ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_1)) THEN 1927 1917 IF (l_dbg) THEN 1928 1918 WRITE(*,*) & 1929 & c_nam//" : re-allocate buff_tmp for buff_sz= ", &1930 & W_F( pfileid)%W_V(varid)%datasz_max1919 & c_nam//" : re-allocate tbf_1 for size = ", & 1920 & W_F(idf)%W_V(iv)%datasz_max 1931 1921 ENDIF 1932 DEALLOCATE(buff_tmp) 1933 ALLOCATE(buff_tmp(W_F(pfileid)%W_V(varid)%datasz_max)) 1934 buff_tmp_sz = W_F(pfileid)%W_V(varid)%datasz_max 1922 DEALLOCATE(tbf_1) 1923 ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max)) 1935 1924 ENDIF 1936 1925 !- … … 1939 1928 !-- of the data at the same time. This should speed up things. 1940 1929 !- 1941 nbpt_out = W_F( pfileid)%W_V(varid)%datasz_max1930 nbpt_out = W_F(idf)%W_V(iv)%datasz_max 1942 1931 IF (l1d) THEN 1943 nbpt_in1 = W_F( pfileid)%W_V(varid)%datasz_in(1)1944 CALL mathop (W_F( pfileid)%W_V(varid)%sopp(1),nbpt_in1,pdata_1d, &1932 nbpt_in1 = W_F(idf)%W_V(iv)%datasz_in(1) 1933 CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in1,pdata_1d, & 1945 1934 & missing_val,nbindex,nindex, & 1946 & W_F( pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp)1935 & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) 1947 1936 ELSE IF (l2d) THEN 1948 nbpt_in2(1:2) = W_F( pfileid)%W_V(varid)%datasz_in(1:2)1949 CALL mathop (W_F( pfileid)%W_V(varid)%sopp(1),nbpt_in2,pdata_2d, &1937 nbpt_in2(1:2) = W_F(idf)%W_V(iv)%datasz_in(1:2) 1938 CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in2,pdata_2d, & 1950 1939 & missing_val,nbindex,nindex, & 1951 & W_F( pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp)1940 & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) 1952 1941 ELSE IF (l3d) THEN 1953 nbpt_in3(1:3) = W_F( pfileid)%W_V(varid)%datasz_in(1:3)1954 CALL mathop (W_F( pfileid)%W_V(varid)%sopp(1),nbpt_in3,pdata_3d, &1942 nbpt_in3(1:3) = W_F(idf)%W_V(iv)%datasz_in(1:3) 1943 CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in3,pdata_3d, & 1955 1944 & missing_val,nbindex,nindex, & 1956 & W_F( pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp)1957 ENDIF 1958 CALL histwrite_real ( pfileid,varid,pitau,nbpt_out, &1959 & buff_tmp,nbindex,nindex,do_oper,do_write)1945 & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) 1946 ENDIF 1947 CALL histwrite_real (idf,iv,pitau,nbpt_out, & 1948 & tbf_1,nbindex,nindex,do_oper,do_write) 1960 1949 ENDIF 1961 1950 !- … … 1963 1952 !- 1964 1953 IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN 1965 W_F( pfileid)%W_V(varid)%last_opp_chk = pitau1966 W_F( pfileid)%W_V(varid)%last_wrt_chk = pitau1967 ELSE 1968 W_F( pfileid)%W_V(varid)%last_opp_chk = -991969 W_F( pfileid)%W_V(varid)%last_wrt_chk = -991954 W_F(idf)%W_V(iv)%last_opp_chk = pitau 1955 W_F(idf)%W_V(iv)%last_wrt_chk = pitau 1956 ELSE 1957 W_F(idf)%W_V(iv)%last_opp_chk = -99 1958 W_F(idf)%W_V(iv)%last_wrt_chk = -99 1970 1959 ENDIF 1971 1960 !----------------------- … … 1973 1962 !=== 1974 1963 SUBROUTINE histwrite_real & 1975 & ( pfileid,varid,pitau,nbdpt,buff_tmp,nbindex,nindex,do_oper,do_write)1964 & (idf,iv,pitau,nbdpt,tbf_1,nbindex,nindex,do_oper,do_write) 1976 1965 !--------------------------------------------------------------------- 1977 1966 !- This subroutine is internal and does the calculations and writing … … 1981 1970 IMPLICIT NONE 1982 1971 !- 1983 INTEGER,INTENT(IN) :: pfileid,pitau,varid, &1972 INTEGER,INTENT(IN) :: idf,pitau,iv, & 1984 1973 & nbindex,nindex(nbindex),nbdpt 1985 REAL,DIMENSION(:) :: buff_tmp1974 REAL,DIMENSION(:) :: tbf_1 1986 1975 LOGICAL,INTENT(IN) :: do_oper,do_write 1987 1976 !- 1988 INTEGER :: tsz,nfid,nvid,i ,iret,ipt,itax,io,nbin,nbout1977 INTEGER :: tsz,nfid,nvid,iret,itax,io,nbin,nbout 1989 1978 INTEGER :: nx,ny,nz,ky,kz,kt,kc 1990 1979 INTEGER,DIMENSION(4) :: corner,edges … … 1993 1982 REAL :: rtime 1994 1983 CHARACTER(LEN=7) :: tmp_opp 1995 REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buff_tmp2,buffer_used 1996 INTEGER,SAVE :: buff_tmp2_sz,buffer_sz 1984 REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_2 1997 1985 LOGICAL :: l_dbg 1998 1986 !--------------------------------------------------------------------- … … 2000 1988 !- 2001 1989 IF (l_dbg) THEN 2002 WRITE(*,*) "histwrite 0.0 : VAR : ",W_F( pfileid)%W_V(varid)%v_name1990 WRITE(*,*) "histwrite 0.0 : VAR : ",W_F(idf)%W_V(iv)%v_name 2003 1991 WRITE(*,*) "histwrite 0.0 : nbindex,nindex :", & 2004 1992 & nbindex,nindex(1:MIN(3,nbindex)),'...',nindex(MAX(1,nbindex-3):nbindex) … … 2007 1995 ! The sizes which can be encoutered 2008 1996 !- 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) 2012 !- 2013 ! 1.0 We allocate the memory needed to store the data between write 2014 ! and the temporary space needed for operations. 2015 ! We have to keep precedent buffer if needed 2016 !- 2017 IF (.NOT. ALLOCATED(buffer)) THEN 2018 IF (l_dbg) WRITE(*,*) "histwrite_real 1.0 allocate buffer ",buff_pos 2019 ALLOCATE(buffer(buff_pos)) 2020 buffer_sz = buff_pos 2021 buffer(:)=0.0 2022 ELSE IF (buffer_sz < buff_pos) THEN 1997 tsz = W_F(idf)%W_V(iv)%zsize(1) & 1998 & *W_F(idf)%W_V(iv)%zsize(2) & 1999 & *W_F(idf)%W_V(iv)%zsize(3) 2000 !- 2001 ! 1.0 We allocate and the temporary space needed for operations. 2002 ! The buffers are only deallocated when more space is needed. 2003 ! This reduces the umber of allocates but increases memory needs. 2004 !- 2005 IF (.NOT.ALLOCATED(tbf_2)) THEN 2023 2006 IF (l_dbg) THEN 2024 WRITE(*,*) "histwrite_real 1.0.1 re-allocate buffer for ", & 2025 & buff_pos," instead of ",SIZE(buffer) 2026 ENDIF 2027 IF (SUM(buffer)/=0.0) THEN 2028 IF (l_dbg) WRITE (*,*) 'histwrite : buffer has been used. ', & 2029 & 'We have to save it before re-allocating.' 2030 ALLOCATE(buffer_used(buffer_sz)) 2031 buffer_used(:)=buffer(:) 2032 DEALLOCATE(buffer) 2033 ALLOCATE(buffer(buff_pos)) 2034 buffer_sz = buff_pos 2035 buffer(:)=0.0 2036 buffer(:SIZE(buffer_used))=buffer_used 2037 DEALLOCATE(buffer_used) 2038 ELSE 2039 IF (l_dbg) WRITE (*,*) 'histwrite : buffer has not been used. ', & 2040 & 'We have just to re-allocate it.' 2041 DEALLOCATE(buffer) 2042 ALLOCATE(buffer(buff_pos)) 2043 buffer_sz = buff_pos 2044 buffer(:)=0.0 2045 ENDIF 2046 ENDIF 2047 !- 2048 ! The buffers are only deallocated when more space is needed. This 2049 ! reduces the umber of allocates but increases memory needs. 2050 !- 2051 IF (.NOT.ALLOCATED(buff_tmp2)) THEN 2007 WRITE(*,*) "histwrite_real 1.1 allocate tbf_2 ",SIZE(tbf_1) 2008 ENDIF 2009 ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max)) 2010 ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_2)) THEN 2052 2011 IF (l_dbg) THEN 2053 WRITE(*,*) "histwrite_real 1.1 allocate buff_tmp2 ",SIZE(buff_tmp) 2054 ENDIF 2055 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 2058 IF (l_dbg) THEN 2059 WRITE(*,*) "histwrite_real 1.2 re-allocate buff_tmp2 : ", & 2060 & SIZE(buff_tmp)," instead of ",SIZE(buff_tmp2) 2061 ENDIF 2062 DEALLOCATE(buff_tmp2) 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 2069 !- 2070 ! 3.0 Do the operations or transfer the slab of data into buff_tmp 2071 !- 2072 IF (l_dbg) WRITE(*,*) "histwrite: 3.0",pfileid 2012 WRITE(*,*) "histwrite_real 1.2 re-allocate tbf_2 : ", & 2013 & SIZE(tbf_1)," instead of ",SIZE(tbf_2) 2014 ENDIF 2015 DEALLOCATE(tbf_2) 2016 ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max)) 2017 ENDIF 2018 !- 2019 rtime = pitau*W_F(idf)%deltat 2020 tmp_opp = W_F(idf)%W_V(iv)%topp 2021 !- 2022 ! 3.0 Do the operations or transfer the slab of data into tbf_1 2023 !- 2024 IF (l_dbg) THEN 2025 WRITE(*,*) "histwrite: 3.0",idf 2026 ENDIF 2073 2027 !- 2074 2028 ! 3.1 DO the Operations only if needed 2075 2029 !- 2076 2030 IF (do_oper) THEN 2077 i = pfileid2078 2031 nbout = nbdpt 2079 2032 !- … … 2081 2034 !-- we started in the interface routine 2082 2035 !- 2083 DO io=2,W_F(i )%W_V(varid)%nbopp,22036 DO io=2,W_F(idf)%W_V(iv)%nbopp,2 2084 2037 nbin = nbout 2085 nbout = W_F(i )%W_V(varid)%datasz_max2086 CALL mathop(W_F(i )%W_V(varid)%sopp(io),nbin,buff_tmp, &2087 & missing_val,nbindex,nindex,W_F(i )%W_V(varid)%scal(io), &2088 & nbout, buff_tmp2)2038 nbout = W_F(idf)%W_V(iv)%datasz_max 2039 CALL mathop(W_F(idf)%W_V(iv)%sopp(io),nbin,tbf_1, & 2040 & missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io), & 2041 & nbout,tbf_2) 2089 2042 IF (l_dbg) THEN 2090 2043 WRITE(*,*) & 2091 & "histwrite: 3.4a nbout : ",nbin,nbout,W_F(i )%W_V(varid)%sopp(io)2044 & "histwrite: 3.4a nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io) 2092 2045 ENDIF 2093 2046 !- 2094 2047 nbin = nbout 2095 nbout = W_F(i )%W_V(varid)%datasz_max2096 CALL mathop(W_F(i )%W_V(varid)%sopp(io+1),nbin,buff_tmp2, &2097 & missing_val,nbindex,nindex,W_F(i )%W_V(varid)%scal(io+1), &2098 & nbout, buff_tmp)2048 nbout = W_F(idf)%W_V(iv)%datasz_max 2049 CALL mathop(W_F(idf)%W_V(iv)%sopp(io+1),nbin,tbf_2, & 2050 & missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io+1), & 2051 & nbout,tbf_1) 2099 2052 IF (l_dbg) THEN 2100 2053 WRITE(*,*) & 2101 & "histwrite: 3.4b nbout : ",nbin,nbout,W_F(i )%W_V(varid)%sopp(io+1)2054 & "histwrite: 3.4b nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io+1) 2102 2055 ENDIF 2103 2056 ENDDO … … 2107 2060 IF (l_dbg) THEN 2108 2061 WRITE(*,*) & 2109 & "histwrite: 3.5 size( buff_tmp) : ",SIZE(buff_tmp)2062 & "histwrite: 3.5 size(tbf_1) : ",SIZE(tbf_1) 2110 2063 WRITE(*,*) & 2111 2064 & "histwrite: 3.5 slab in X :", & 2112 & W_F(i )%W_V(varid)%zorig(1),W_F(i)%W_V(varid)%zsize(1)2065 & W_F(idf)%W_V(iv)%zorig(1),W_F(idf)%W_V(iv)%zsize(1) 2113 2066 WRITE(*,*) & 2114 2067 & "histwrite: 3.5 slab in Y :", & 2115 & W_F(i )%W_V(varid)%zorig(2),W_F(i)%W_V(varid)%zsize(2)2068 & W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zsize(2) 2116 2069 WRITE(*,*) & 2117 2070 & "histwrite: 3.5 slab in Z :", & 2118 & W_F(i )%W_V(varid)%zorig(3),W_F(i)%W_V(varid)%zsize(3)2071 & W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zsize(3) 2119 2072 WRITE(*,*) & 2120 2073 & "histwrite: 3.5 slab of input:", & 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)2074 & W_F(idf)%W_V(iv)%scsize(1), & 2075 & W_F(idf)%W_V(iv)%scsize(2), & 2076 & W_F(idf)%W_V(iv)%scsize(3) 2124 2077 ENDIF 2125 2078 !--- 2126 2079 !-- We have to consider blocks of contiguous data 2127 2080 !--- 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))) THEN2137 kt = (W_F(i )%W_V(varid)%zorig(3)-1)*nx*ny2138 buff_tmp2(1:nx*ny*nz) = buff_tmp(kt+1:kt+nx*ny*nz)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))) THEN2081 nx=MAX(W_F(idf)%W_V(iv)%zsize(1),1) 2082 ny=MAX(W_F(idf)%W_V(iv)%zsize(2),1) 2083 nz=MAX(W_F(idf)%W_V(iv)%zsize(3),1) 2084 IF ( (W_F(idf)%W_V(iv)%zorig(1) == 1) & 2085 & .AND.( W_F(idf)%W_V(iv)%zsize(1) & 2086 & == W_F(idf)%W_V(iv)%scsize(1)) & 2087 & .AND.(W_F(idf)%W_V(iv)%zorig(2) == 1) & 2088 & .AND.( W_F(idf)%W_V(iv)%zsize(2) & 2089 & == W_F(idf)%W_V(iv)%scsize(2))) THEN 2090 kt = (W_F(idf)%W_V(iv)%zorig(3)-1)*nx*ny 2091 tbf_2(1:nx*ny*nz) = tbf_1(kt+1:kt+nx*ny*nz) 2092 ELSEIF ( (W_F(idf)%W_V(iv)%zorig(1) == 1) & 2093 & .AND.( W_F(idf)%W_V(iv)%zsize(1) & 2094 & == W_F(idf)%W_V(iv)%scsize(1))) THEN 2142 2095 kc = -nx*ny 2143 DO kz=W_F(i )%W_V(varid)%zorig(3),W_F(i)%W_V(varid)%zorig(3)+nz-12096 DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1 2144 2097 kc = kc+nx*ny 2145 kt = ( (kz-1)*W_F(i )%W_V(varid)%scsize(2) &2146 & +W_F(i )%W_V(varid)%zorig(2)-1)*nx2147 buff_tmp2(kc+1:kc+nx*ny) = buff_tmp(kt+1:kt+nx*ny)2098 kt = ( (kz-1)*W_F(idf)%W_V(iv)%scsize(2) & 2099 & +W_F(idf)%W_V(iv)%zorig(2)-1)*nx 2100 tbf_2(kc+1:kc+nx*ny) = tbf_1(kt+1:kt+nx*ny) 2148 2101 ENDDO 2149 2102 ELSE 2150 2103 kc = -nx 2151 DO kz=W_F(i )%W_V(varid)%zorig(3),W_F(i)%W_V(varid)%zorig(3)+nz-12152 DO ky=W_F(i )%W_V(varid)%zorig(2),W_F(i)%W_V(varid)%zorig(2)+ny-12104 DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1 2105 DO ky=W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zorig(2)+ny-1 2153 2106 kc = kc+nx 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)-12157 buff_tmp2(kc+1:kc+nx) = buff_tmp(kt+1:kt+nx)2107 kt = ((kz-1)*W_F(idf)%W_V(iv)%scsize(2)+ky-1) & 2108 & *W_F(idf)%W_V(iv)%scsize(1) & 2109 & +W_F(idf)%W_V(iv)%zorig(1)-1 2110 tbf_2(kc+1:kc+nx) = tbf_1(kt+1:kt+nx) 2158 2111 ENDDO 2159 2112 ENDDO 2160 2113 ENDIF 2161 2114 !- 2162 !-- 4.0 Get the min and max of the field (buff_tmp) 2163 !- 2164 IF (l_dbg) WRITE(*,*) "histwrite: 4.0 buff_tmp",pfileid,varid, & 2165 & TRIM(tmp_opp),' ---- ',LEN_TRIM(tmp_opp),nbindex 2166 !- 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), & 2170 & MINVAL(buff_tmp2(1:tsz),MASK=buff_tmp2(1:tsz) /= missing_val)) 2171 W_F(pfileid)%W_V(varid)%hist_minmax(2) = & 2172 & MAX(W_F(pfileid)%W_V(varid)%hist_minmax(2), & 2173 & MAXVAL(buff_tmp2(1:tsz),MASK=buff_tmp2(1:tsz) /= missing_val)) 2115 !-- 4.0 Get the min and max of the field 2116 !- 2117 IF (l_dbg) THEN 2118 WRITE(*,*) "histwrite: 4.0 tbf_1",idf,iv, & 2119 & TRIM(tmp_opp),' ---- ',LEN_TRIM(tmp_opp),nbindex 2120 ENDIF 2121 !- 2122 IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN 2123 W_F(idf)%W_V(iv)%hist_minmax(1) = & 2124 & MIN(W_F(idf)%W_V(iv)%hist_minmax(1), & 2125 & MINVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val)) 2126 W_F(idf)%W_V(iv)%hist_minmax(2) = & 2127 & MAX(W_F(idf)%W_V(iv)%hist_minmax(2), & 2128 & MAXVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val)) 2174 2129 ENDIF 2175 2130 !- 2176 2131 !-- 5.0 Do the operations if needed. In the case of instantaneous 2177 !-- output we do not transfer to the buffer. 2178 !- 2179 IF (l_dbg) WRITE(*,*) "histwrite: 5.0",pfileid,"tsz :",tsz 2180 !- 2181 ipt = W_F(pfileid)%W_V(varid)%point 2182 !- 2183 ! WRITE(*,*) 'OPE ipt, buffer :',pvarname,ipt,varid 2132 !-- output we do not transfer to the time_buffer. 2133 !- 2134 IF (l_dbg) THEN 2135 WRITE(*,*) "histwrite: 5.0 idf : ",idf," iv : ",iv," tsz : ",tsz 2136 ENDIF 2184 2137 !- 2185 2138 IF ( (TRIM(tmp_opp) /= "inst") & 2186 2139 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2187 CALL moycum(tmp_opp,tsz, buffer(ipt:), &2188 & buff_tmp2,W_F(pfileid)%W_V(varid)%nb_opp)2189 ENDIF 2190 !- 2191 W_F( pfileid)%W_V(varid)%last_opp = pitau2192 W_F( pfileid)%W_V(varid)%nb_opp = W_F(pfileid)%W_V(varid)%nb_opp+12140 CALL moycum(tmp_opp,tsz,W_F(idf)%W_V(iv)%t_bf, & 2141 & tbf_2,W_F(idf)%W_V(iv)%nb_opp) 2142 ENDIF 2143 !- 2144 W_F(idf)%W_V(iv)%last_opp = pitau 2145 W_F(idf)%W_V(iv)%nb_opp = W_F(idf)%W_V(iv)%nb_opp+1 2193 2146 !- 2194 2147 ENDIF … … 2196 2149 ! 6.0 Write to file if needed 2197 2150 !- 2198 IF (l_dbg) WRITE(*,*) "histwrite: 6.0", pfileid2151 IF (l_dbg) WRITE(*,*) "histwrite: 6.0",idf 2199 2152 !- 2200 2153 IF (do_write) THEN 2201 2154 !- 2202 nfid = W_F( pfileid)%ncfid2203 nvid = W_F( pfileid)%W_V(varid)%ncvid2155 nfid = W_F(idf)%ncfid 2156 nvid = W_F(idf)%W_V(iv)%ncvid 2204 2157 !- 2205 2158 !-- 6.1 Do the operations that are needed before writting 2206 2159 !- 2207 IF (l_dbg) WRITE(*,*) "histwrite: 6.1", pfileid2160 IF (l_dbg) WRITE(*,*) "histwrite: 6.1",idf 2208 2161 !- 2209 2162 IF ( (TRIM(tmp_opp) /= "inst") & 2210 2163 & .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 rtime = (rtime+W_F(idf)%W_V(iv)%last_wrt*W_F(idf)%deltat)/2.0 2213 2165 ENDIF 2214 2166 !- … … 2219 2171 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2220 2172 !- 2221 IF (l_dbg) WRITE(*,*) "histwrite: 6.2", pfileid2222 !- 2223 itax = W_F(pfileid)%W_V(varid)%t_axid2224 itime = W_F( pfileid)%W_V(varid)%nb_wrt+12225 !- 2226 IF (W_F( pfileid)%W_V(itax)%tax_last < itime) THEN2227 iret = NF90_PUT_VAR (nfid,W_F( pfileid)%W_V(itax)%tdimid, &2173 IF (l_dbg) WRITE(*,*) "histwrite: 6.2",idf 2174 !- 2175 itax = W_F(idf)%W_V(iv)%t_axid 2176 itime = W_F(idf)%W_V(iv)%nb_wrt+1 2177 !- 2178 IF (W_F(idf)%W_V(itax)%tax_last < itime) THEN 2179 iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tdimid, & 2228 2180 & (/ rtime /),start=(/ itime /),count=(/ 1 /)) 2229 W_F( pfileid)%W_V(itax)%tax_last = itime2181 W_F(idf)%W_V(itax)%tax_last = itime 2230 2182 ENDIF 2231 2183 ELSE … … 2237 2189 !- 2238 2190 IF (l_dbg) THEN 2239 WRITE(*,*) "histwrite: 6.3", pfileid,nfid,nvid,varid,itime2240 ENDIF 2241 !- 2242 IF (W_F( pfileid)%W_V(varid)%scsize(3) == 1) THEN2243 IF (W_F( pfileid)%regular) THEN2191 WRITE(*,*) "histwrite: 6.3",idf,nfid,nvid,iv,itime 2192 ENDIF 2193 !- 2194 IF (W_F(idf)%W_V(iv)%scsize(3) == 1) THEN 2195 IF (W_F(idf)%regular) THEN 2244 2196 corner(1:4) = (/ 1,1,itime,0 /) 2245 edges(1:4) = (/ W_F( pfileid)%W_V(varid)%zsize(1), &2246 & W_F( pfileid)%W_V(varid)%zsize(2),1,0 /)2197 edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & 2198 & W_F(idf)%W_V(iv)%zsize(2),1,0 /) 2247 2199 ELSE 2248 2200 corner(1:4) = (/ 1,itime,0,0 /) 2249 edges(1:4) = (/ W_F( pfileid)%W_V(varid)%zsize(1),1,0,0 /)2201 edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1),1,0,0 /) 2250 2202 ENDIF 2251 2203 ELSE 2252 IF (W_F( pfileid)%regular) THEN2204 IF (W_F(idf)%regular) THEN 2253 2205 corner(1:4) = (/ 1,1,1,itime /) 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 /)2206 edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & 2207 & W_F(idf)%W_V(iv)%zsize(2), & 2208 & W_F(idf)%W_V(iv)%zsize(3),1 /) 2257 2209 ELSE 2258 2210 corner(1:4) = (/ 1,1,itime,0 /) 2259 edges(1:4) = (/ W_F( pfileid)%W_V(varid)%zsize(1), &2260 & W_F( pfileid)%W_V(varid)%zsize(3),1,0 /)2211 edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & 2212 & W_F(idf)%W_V(iv)%zsize(3),1,0 /) 2261 2213 ENDIF 2262 2214 ENDIF 2263 !-2264 ipt = W_F(pfileid)%W_V(varid)%point2265 2215 !- 2266 2216 IF ( (TRIM(tmp_opp) /= "inst") & 2267 2217 & .AND.(TRIM(tmp_opp) /= "once") ) THEN 2268 iret = NF90_PUT_VAR (nfid,nvid, buffer(ipt:), &2269 & start=corner(1:4),count=edges(1:4))2218 iret = NF90_PUT_VAR (nfid,nvid,W_F(idf)%W_V(iv)%t_bf, & 2219 & start=corner(1:4),count=edges(1:4)) 2270 2220 ELSE 2271 iret = NF90_PUT_VAR (nfid,nvid, buff_tmp2, &2272 & start=corner(1:4),count=edges(1:4))2273 ENDIF 2274 !- 2275 W_F( pfileid)%W_V(varid)%last_wrt = pitau2276 W_F( pfileid)%W_V(varid)%nb_wrt = W_F(pfileid)%W_V(varid)%nb_wrt+12277 W_F( pfileid)%W_V(varid)%nb_opp = 02221 iret = NF90_PUT_VAR (nfid,nvid,tbf_2, & 2222 & start=corner(1:4),count=edges(1:4)) 2223 ENDIF 2224 !- 2225 W_F(idf)%W_V(iv)%last_wrt = pitau 2226 W_F(idf)%W_V(iv)%nb_wrt = W_F(idf)%W_V(iv)%nb_wrt+1 2227 W_F(idf)%W_V(iv)%nb_opp = 0 2278 2228 !--- 2279 2229 ! After the write the file can be synchronized so that no data is … … 2288 2238 END SUBROUTINE histwrite_real 2289 2239 !=== 2290 SUBROUTINE histvar_seq ( pfid,pvarname,pvid)2291 !--------------------------------------------------------------------- 2292 !- This subroutine optimize dthe search for the variable in the table.2240 SUBROUTINE histvar_seq (idf,pvarname,idv) 2241 !--------------------------------------------------------------------- 2242 !- This subroutine optimize the search for the variable in the table. 2293 2243 !- In a first phase it will learn the succession of the variables 2294 2244 !- called and then it will use the table to guess what comes next. … … 2298 2248 !- ARGUMENTS : 2299 2249 !- 2300 !- pfid: id of the file on which we work2250 !- idf : id of the file on which we work 2301 2251 !- pvarname : The name of the variable we are looking for 2302 !- pvid: The var id we found2252 !- idv : The var id we found 2303 2253 !--------------------------------------------------------------------- 2304 2254 IMPLICIT NONE 2305 2255 !- 2306 INTEGER,INTENT(in) :: pfid2256 INTEGER,INTENT(in) :: idf 2307 2257 CHARACTER(LEN=*),INTENT(IN) :: pvarname 2308 INTEGER,INTENT(out) :: pvid2258 INTEGER,INTENT(out) :: idv 2309 2259 !- 2310 2260 LOGICAL,SAVE :: learning(nb_files_max)=.TRUE. … … 2321 2271 !- 2322 2272 IF (l_dbg) THEN 2323 WRITE(*,*) 'histvar_seq, start of the subroutine :',learning( pfid)2324 ENDIF 2325 !- 2326 IF (learning( pfid)) THEN2273 WRITE(*,*) 'histvar_seq, start of the subroutine :',learning(idf) 2274 ENDIF 2275 !- 2276 IF (learning(idf)) THEN 2327 2277 !- 2328 2278 !-- 1.0 We compute the length over which we are going 2329 2279 !-- to check the overlap 2330 2280 !- 2331 IF (overlap( pfid) <= 0) THEN2332 IF (W_F( pfid)%n_var > 6) THEN2333 overlap( pfid) = W_F(pfid)%n_var/3*22281 IF (overlap(idf) <= 0) THEN 2282 IF (W_F(idf)%n_var > 6) THEN 2283 overlap(idf) = W_F(idf)%n_var/3*2 2334 2284 ELSE 2335 overlap( pfid) = W_F(pfid)%n_var2285 overlap(idf) = W_F(idf)%n_var 2336 2286 ENDIF 2337 2287 ENDIF … … 2339 2289 !-- 1.1 Find the position of this string 2340 2290 !- 2341 CALL find_str (W_F( pfid)%W_V(1:W_F(pfid)%n_var)%v_name,pvarname,pos)2291 CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos) 2342 2292 IF (pos > 0) THEN 2343 pvid= pos2293 idv = pos 2344 2294 ELSE 2345 2295 CALL ipslerr (3,"histvar_seq", & … … 2352 2302 !-- in the sequence of calls 2353 2303 !- 2354 IF (varseq_err( pfid) >= 0) THEN2355 sp = varseq_len( pfid)+12304 IF (varseq_err(idf) >= 0) THEN 2305 sp = varseq_len(idf)+1 2356 2306 IF (sp <= nb_var_max*3) THEN 2357 varseq( pfid,sp) = pvid2358 varseq_len( pfid) = sp2307 varseq(idf,sp) = idv 2308 varseq_len(idf) = sp 2359 2309 ELSE 2360 2310 CALL ipslerr (2,"histvar_seq",& … … 2366 2316 & ' contact the IOIPSL team. ') 2367 2317 WRITE(*,*) 'The sequence we have found up to now :' 2368 WRITE(*,*) varseq( pfid,1:sp-1)2369 varseq_err( pfid) = -12318 WRITE(*,*) varseq(idf,1:sp-1) 2319 varseq_err(idf) = -1 2370 2320 ENDIF 2371 2321 !- 2372 2322 !---- 1.3 Check if we have found the right overlap 2373 2323 !- 2374 IF (varseq_len( pfid) >= overlap(pfid)*2) THEN2324 IF (varseq_len(idf) >= overlap(idf)*2) THEN 2375 2325 !- 2376 2326 !------ We skip a few variables if needed as they could come 2377 2327 !------ from the initialisation of the model. 2378 2328 !- 2379 DO ib = 0,sp-overlap( pfid)*22380 IF ( learning( pfid) .AND.&2381 & SUM(ABS(varseq( pfid,ib+1:ib+overlap(pfid)) -&2382 & varseq( pfid,sp-overlap(pfid)+1:sp))) == 0 ) THEN2383 learning( pfid) = .FALSE.2384 varseq_len( pfid) = sp-overlap(pfid)-ib2385 varseq_pos( pfid) = overlap(pfid)+ib2386 varseq( pfid,1:varseq_len(pfid)) = &2387 & varseq( pfid,ib+1:ib+varseq_len(pfid))2329 DO ib = 0,sp-overlap(idf)*2 2330 IF ( learning(idf) .AND.& 2331 & SUM(ABS(varseq(idf,ib+1:ib+overlap(idf)) -& 2332 & varseq(idf,sp-overlap(idf)+1:sp))) == 0 ) THEN 2333 learning(idf) = .FALSE. 2334 varseq_len(idf) = sp-overlap(idf)-ib 2335 varseq_pos(idf) = overlap(idf)+ib 2336 varseq(idf,1:varseq_len(idf)) = & 2337 & varseq(idf,ib+1:ib+varseq_len(idf)) 2388 2338 ENDIF 2389 2339 ENDDO … … 2395 2345 !-- and we can get a guess at the var ID 2396 2346 !- 2397 nn = varseq_pos( pfid)+12398 IF (nn > varseq_len( pfid)) nn = 12399 !- 2400 pvid = varseq(pfid,nn)2401 !- 2402 IF (TRIM(W_F( pfid)%W_V(pvid)%v_name) /= TRIM(pvarname)) THEN2403 CALL find_str (W_F( pfid)%W_V(1:W_F(pfid)%n_var)%v_name,pvarname,pos)2347 nn = varseq_pos(idf)+1 2348 IF (nn > varseq_len(idf)) nn = 1 2349 !- 2350 idv = varseq(idf,nn) 2351 !- 2352 IF (TRIM(W_F(idf)%W_V(idv)%v_name) /= TRIM(pvarname)) THEN 2353 CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos) 2404 2354 IF (pos > 0) THEN 2405 pvid= pos2355 idv = pos 2406 2356 ELSE 2407 2357 CALL ipslerr (3,"histvar_seq", & … … 2410 2360 & TRIM(pvarname)) 2411 2361 ENDIF 2412 varseq_err( pfid) = varseq_err(pfid)+12362 varseq_err(idf) = varseq_err(idf)+1 2413 2363 ELSE 2414 2364 !- … … 2417 2367 !---- not defeat the process. 2418 2368 !- 2419 varseq_pos( pfid) = nn2420 ENDIF 2421 !- 2422 IF (varseq_err( pfid) >= 10) THEN2423 WRITE(str70,'("for file ",I3)') pfid2369 varseq_pos(idf) = nn 2370 ENDIF 2371 !- 2372 IF (varseq_err(idf) >= 10) THEN 2373 WRITE(str70,'("for file ",I3)') idf 2424 2374 CALL ipslerr (2,"histvar_seq", & 2425 2375 & 'There were 10 errors in the learned sequence of variables',& 2426 2376 & str70,'This looks like a bug, please report it.') 2427 varseq_err( pfid) = 02377 varseq_err(idf) = 0 2428 2378 ENDIF 2429 2379 ENDIF … … 2431 2381 IF (l_dbg) THEN 2432 2382 WRITE(*,*) & 2433 & 'histvar_seq, end of the subroutine :',TRIM(pvarname), pvid2383 & 'histvar_seq, end of the subroutine :',TRIM(pvarname),idv 2434 2384 ENDIF 2435 2385 !------------------------- … … 2480 2430 END SUBROUTINE histsync 2481 2431 !=== 2482 SUBROUTINE histclo ( fid)2432 SUBROUTINE histclo (idf) 2483 2433 !--------------------------------------------------------------------- 2484 2434 !- This subroutine will close all (or one if defined) opened files … … 2489 2439 IMPLICIT NONE 2490 2440 !- 2491 ! fid: optional argument for fileid2492 INTEGER,INTENT(in),OPTIONAL :: fid2441 ! idf : optional argument for fileid 2442 INTEGER,INTENT(in),OPTIONAL :: idf 2493 2443 !- 2494 2444 INTEGER :: ifile,nfid,nvid,iret,iv … … 2501 2451 IF (l_dbg) WRITE(*,*) 'Entering loop on files :',nb_files 2502 2452 !- 2503 IF (PRESENT( fid)) THEN2504 start_loop = fid2505 end_loop = fid2453 IF (PRESENT(idf)) THEN 2454 start_loop = idf 2455 end_loop = idf 2506 2456 ELSE 2507 2457 start_loop = 1
Note: See TracChangeset
for help on using the changeset viewer.
