Changeset 13710 for NEMO/branches/2020/dev_r12702_ASINTER-02_emanuelaclementi_Waves/src/OCE/IOM/iom.F90
- Timestamp:
- 2020-11-02T10:56:42+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r12702_ASINTER-02_emanuelaclementi_Waves
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/IOM/iom.F90 (modified) (55 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r12702_ASINTER-02_emanuelaclementi_Waves
- Property svn:externals
-
old new 3 3 ^/utils/build/mk@HEAD mk 4 4 ^/utils/tools@HEAD tools 5 ^/vendors/AGRIF/dev @HEADext/AGRIF5 ^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL 8 8 9 9 # SETTE 10 ^/utils/CI/sette@ HEADsette10 ^/utils/CI/sette@13559 sette
-
- Property svn:externals
-
NEMO/branches/2020/dev_r12702_ASINTER-02_emanuelaclementi_Waves/src/OCE/IOM/iom.F90
r12649 r13710 21 21 !!---------------------------------------------------------------------- 22 22 USE dom_oce ! ocean space and time domain 23 USE domutl ! 23 24 USE c1d ! 1D vertical configuration 24 25 USE flo_oce ! floats module declarations … … 34 35 USE ice , ONLY : jpl 35 36 #endif 36 USE domngb ! ocean space and time domain37 37 USE phycst ! physical constants 38 38 USE dianam ! build name of file … … 59 59 PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val 60 60 61 PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 62 PRIVATE iom_g0d, iom_g1d, iom_g2d, iom_g3d, iom_get_123d 63 PRIVATE iom_p1d, iom_p2d, iom_p3d, iom_p4d 61 PRIVATE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp 62 PRIVATE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp 63 PRIVATE iom_get_123d 64 PRIVATE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp 65 PRIVATE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp 66 PRIVATE iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp 67 PRIVATE iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp 64 68 #if defined key_iomput 65 69 PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr … … 70 74 71 75 INTERFACE iom_get 72 MODULE PROCEDURE iom_g0d, iom_g1d, iom_g2d, iom_g3d 76 MODULE PROCEDURE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp 77 MODULE PROCEDURE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp 73 78 END INTERFACE 74 79 INTERFACE iom_getatt … … 79 84 END INTERFACE 80 85 INTERFACE iom_rstput 81 MODULE PROCEDURE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 86 MODULE PROCEDURE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp 87 MODULE PROCEDURE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp 82 88 END INTERFACE 83 89 INTERFACE iom_put 84 MODULE PROCEDURE iom_p0d, iom_p1d, iom_p2d, iom_p3d, iom_p4d 90 MODULE PROCEDURE iom_p0d_sp, iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp 91 MODULE PROCEDURE iom_p0d_dp, iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp 85 92 END INTERFACE iom_put 86 93 … … 94 101 CONTAINS 95 102 96 SUBROUTINE iom_init( cdname, fname, ld_ tmppatch, ld_closedef )103 SUBROUTINE iom_init( cdname, fname, ld_closedef ) 97 104 !!---------------------------------------------------------------------- 98 105 !! *** ROUTINE *** … … 103 110 CHARACTER(len=*), INTENT(in) :: cdname 104 111 CHARACTER(len=*), OPTIONAL, INTENT(in) :: fname 105 LOGICAL , OPTIONAL, INTENT(in) :: ld_tmppatch106 112 LOGICAL , OPTIONAL, INTENT(in) :: ld_closedef 107 113 #if defined key_iomput … … 116 122 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds 117 123 REAL(wp), DIMENSION(2,jpkam1) :: za_bnds ! ABL vertical boundaries 118 LOGICAL :: ll_tmppatch = .TRUE. !: seb: patch before we remove periodicity119 INTEGER :: nldi_save, nlei_save !: and close boundaries in output files120 INTEGER :: nldj_save, nlej_save !:121 124 LOGICAL :: ll_closedef = .TRUE. 122 !!---------------------------------------------------------------------- 123 ! 124 ! seb: patch before we remove periodicity and close boundaries in output files 125 IF( PRESENT(ld_tmppatch) ) THEN ; ll_tmppatch = ld_tmppatch 126 ELSE ; ll_tmppatch = .TRUE. 127 ENDIF 128 IF ( ll_tmppatch ) THEN 129 nldi_save = nldi ; nlei_save = nlei 130 nldj_save = nldj ; nlej_save = nlej 131 IF( nimpp == 1 ) nldi = 1 132 IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi 133 IF( njmpp == 1 ) nldj = 1 134 IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj 135 ENDIF 125 LOGICAL :: ll_exist 126 !!---------------------------------------------------------------------- 127 ! 136 128 IF ( PRESENT(ld_closedef) ) ll_closedef = ld_closedef 137 129 ! … … 150 142 151 143 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL 152 CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00),&153 & start_date = xios_date(nyear,nmonth,nday,0,0,0) )154 CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00),&155 & start_date = xios_date(nyear,nmonth,nday,0,0,0) )156 CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00),&157 & start_date = xios_date(nyear,nmonth,nday,0,0,0) )144 CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & 145 & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) 146 CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & 147 & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) 148 CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & 149 & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) 158 150 END SELECT 159 151 … … 169 161 ! 170 162 IF( ln_cfmeta ) THEN ! Add additional grid metadata 171 CALL iom_set_domain_attr("grid_T", area = e1e2t(nldi:nlei, nldj:nlej))172 CALL iom_set_domain_attr("grid_U", area = e1e2u(nldi:nlei, nldj:nlej))173 CALL iom_set_domain_attr("grid_V", area = e1e2v(nldi:nlei, nldj:nlej))174 CALL iom_set_domain_attr("grid_W", area = e1e2t(nldi:nlei, nldj:nlej))163 CALL iom_set_domain_attr("grid_T", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 164 CALL iom_set_domain_attr("grid_U", area = real( e1e2u(Nis0:Nie0, Njs0:Nje0), dp)) 165 CALL iom_set_domain_attr("grid_V", area = real( e1e2v(Nis0:Nie0, Njs0:Nje0), dp)) 166 CALL iom_set_domain_attr("grid_W", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 175 167 CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 176 168 CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) … … 192 184 ! 193 185 IF( ln_cfmeta .AND. .NOT. llrst_context) THEN ! Add additional grid metadata 194 CALL iom_set_domain_attr("grid_T", area = e1e2t_crs(nldi:nlei, nldj:nlej))195 CALL iom_set_domain_attr("grid_U", area = e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej))196 CALL iom_set_domain_attr("grid_V", area = e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej))197 CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(nldi:nlei, nldj:nlej))186 CALL iom_set_domain_attr("grid_T", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp)) 187 CALL iom_set_domain_attr("grid_U", area = real(e1u_crs(Nis0:Nie0, Njs0:Nje0) * e2u_crs(Nis0:Nie0, Njs0:Nje0), dp)) 188 CALL iom_set_domain_attr("grid_V", area = real(e1v_crs(Nis0:Nie0, Njs0:Nje0) * e2v_crs(Nis0:Nie0, Njs0:Nje0), dp)) 189 CALL iom_set_domain_attr("grid_W", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp)) 198 190 CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 199 191 CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) … … 239 231 CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) 240 232 241 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) )233 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 242 234 # if defined key_si3 243 235 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) … … 252 244 CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) ) ! strange syntaxe and idea... 253 245 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) ! strange syntaxe and idea... 254 CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,5) /) ) 246 ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) 247 INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) 248 nbasin = 1 + 4 * COUNT( (/ll_exist/) ) 249 CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,nbasin) /) ) 255 250 ENDIF 256 251 ! … … 281 276 DEALLOCATE( zt_bnds, zw_bnds ) 282 277 ! 283 IF ( ll_tmppatch ) THEN284 nldi = nldi_save ; nlei = nlei_save285 nldj = nldj_save ; nlej = nlej_save286 ENDIF287 278 #endif 288 279 ! … … 363 354 rst_file = TRIM(clpath)//TRIM(cn_ocerst_in) 364 355 ELSE 365 rst_file = TRIM(clpath)// '1_'//TRIM(cn_ocerst_in)356 rst_file = TRIM(clpath)//TRIM(Agrif_CFixed())//'_'//TRIM(cn_ocerst_in) 366 357 ENDIF 367 358 !set name of the restart file and enable available fields … … 664 655 665 656 666 SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom,ldstop, ldiof, kdlev, cdcomp )657 SUBROUTINE iom_open( cdname, kiomid, ldwrt, ldstop, ldiof, kdlev, cdcomp ) 667 658 !!--------------------------------------------------------------------- 668 659 !! *** SUBROUTINE iom_open *** … … 673 664 INTEGER , INTENT( out) :: kiomid ! iom identifier of the opened file 674 665 LOGICAL , INTENT(in ), OPTIONAL :: ldwrt ! open in write modeb (default = .FALSE.) 675 INTEGER , INTENT(in ), OPTIONAL :: kdom ! Type of domain to be written (default = jpdom_local_noovlap)676 666 LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) 677 667 LOGICAL , INTENT(in ), OPTIONAL :: ldiof ! Interp On the Fly, needed for AGRIF (default = .FALSE.) … … 686 676 LOGICAL :: llok ! check the existence 687 677 LOGICAL :: llwrt ! local definition of ldwrt 688 LOGICAL :: llnoov ! local definition to read overlap689 678 LOGICAL :: llstop ! local definition of ldstop 690 679 LOGICAL :: lliof ! local definition of ldiof 691 680 INTEGER :: icnt ! counter for digits in clcpu (max = jpmax_digits) 692 681 INTEGER :: iln, ils ! lengths of character 693 INTEGER :: idom ! type of domain694 682 INTEGER :: istop ! 695 INTEGER, DIMENSION(2,5) :: idompar ! domain parameters:696 683 ! local number of points for x,y dimensions 697 684 ! position of first local point for x,y dimensions … … 725 712 ELSE ; lliof = .FALSE. 726 713 ENDIF 727 ! do we read the overlap728 ! ugly patch SM+JMM+RB to overwrite global definition in some cases729 llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif730 714 ! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix) 731 715 ! ============= … … 767 751 lxios_sini = .TRUE. 768 752 ENDIF 769 IF( llwrt ) THEN770 ! check the domain definition771 ! JMM + SM: ugly patch before getting the new version of lib_mpp)772 ! idom = jpdom_local_noovlap ! default definition773 IF( llnoov ) THEN ; idom = jpdom_local_noovlap ! default definition774 ELSE ; idom = jpdom_local_full ! default definition775 ENDIF776 IF( PRESENT(kdom) ) idom = kdom777 ! create the domain informations778 ! =============779 SELECT CASE (idom)780 CASE (jpdom_local_full)781 idompar(:,1) = (/ jpi , jpj /)782 idompar(:,2) = (/ nimpp , njmpp /)783 idompar(:,3) = (/ nimpp + jpi - 1 , njmpp + jpj - 1 /)784 idompar(:,4) = (/ nldi - 1 , nldj - 1 /)785 idompar(:,5) = (/ jpi - nlei , jpj - nlej /)786 CASE (jpdom_local_noextra)787 idompar(:,1) = (/ nlci , nlcj /)788 idompar(:,2) = (/ nimpp , njmpp /)789 idompar(:,3) = (/ nimpp + nlci - 1, njmpp + nlcj - 1 /)790 idompar(:,4) = (/ nldi - 1 , nldj - 1 /)791 idompar(:,5) = (/ nlci - nlei , nlcj - nlej /)792 CASE (jpdom_local_noovlap)793 idompar(:,1) = (/ nlei - nldi + 1, nlej - nldj + 1 /)794 idompar(:,2) = (/ nimpp + nldi - 1, njmpp + nldj - 1 /)795 idompar(:,3) = (/ nimpp + nlei - 1, njmpp + nlej - 1 /)796 idompar(:,4) = (/ 0 , 0 /)797 idompar(:,5) = (/ 0 , 0 /)798 CASE DEFAULT799 CALL ctl_stop( TRIM(clinfo), 'wrong value of kdom, only jpdom_local* cases are accepted' )800 END SELECT801 ENDIF802 753 ! Open the NetCDF file 803 754 ! ============= … … 823 774 ENDIF 824 775 IF( istop == nstop ) THEN ! no error within this routine 825 CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar,kdlev = kdlev, cdcomp = cdcomp )776 CALL iom_nf90_open( clname, kiomid, llwrt, llok, kdlev = kdlev, cdcomp = cdcomp ) 826 777 ENDIF 827 778 ! … … 941 892 !! INTERFACE iom_get 942 893 !!---------------------------------------------------------------------- 943 SUBROUTINE iom_g0d ( kiomid, cdvar, pvar, ktime, ldxios )894 SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime, ldxios ) 944 895 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 945 896 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 946 REAL(wp) , INTENT( out) :: pvar ! read field 897 REAL(sp) , INTENT( out) :: pvar ! read field 898 REAL(dp) :: ztmp_pvar ! tmp var to read field 899 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 900 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart 901 ! 902 INTEGER :: idvar ! variable id 903 INTEGER :: idmspc ! number of spatial dimensions 904 INTEGER , DIMENSION(1) :: itime ! record number 905 CHARACTER(LEN=100) :: clinfo ! info character 906 CHARACTER(LEN=100) :: clname ! file name 907 CHARACTER(LEN=1) :: cldmspc ! 908 LOGICAL :: llxios 909 ! 910 llxios = .FALSE. 911 IF( PRESENT(ldxios) ) llxios = ldxios 912 913 IF(.NOT.llxios) THEN ! read data using default library 914 itime = 1 915 IF( PRESENT(ktime) ) itime = ktime 916 ! 917 clname = iom_file(kiomid)%name 918 clinfo = ' iom_g0d, file: '//trim(clname)//', var: '//trim(cdvar) 919 ! 920 IF( kiomid > 0 ) THEN 921 idvar = iom_varid( kiomid, cdvar ) 922 IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN 923 idmspc = iom_file ( kiomid )%ndims( idvar ) 924 IF( iom_file(kiomid)%luld(idvar) ) idmspc = idmspc - 1 925 WRITE(cldmspc , fmt='(i1)') idmspc 926 IF( idmspc > 0 ) CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', & 927 & 'with 1 or more spatial dimensions: '//cldmspc//' were found.' , & 928 & 'Use ncwa -a to suppress the unnecessary dimensions' ) 929 CALL iom_nf90_get( kiomid, idvar, ztmp_pvar, itime ) 930 pvar = ztmp_pvar 931 ENDIF 932 ENDIF 933 ELSE 934 #if defined key_iomput 935 IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 936 CALL iom_swap( TRIM(crxios_context) ) 937 CALL xios_recv_field( trim(cdvar), pvar) 938 CALL iom_swap( TRIM(cxios_context) ) 939 #else 940 WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) 941 CALL ctl_stop( 'iom_g0d', ctmp1 ) 942 #endif 943 ENDIF 944 END SUBROUTINE iom_g0d_sp 945 946 SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime, ldxios ) 947 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 948 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 949 REAL(dp) , INTENT( out) :: pvar ! read field 947 950 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 948 951 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart … … 989 992 #endif 990 993 ENDIF 991 END SUBROUTINE iom_g0d 992 993 SUBROUTINE iom_g1d ( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios )994 END SUBROUTINE iom_g0d_dp 995 996 SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 994 997 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 995 998 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 996 999 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 997 REAL(wp) , INTENT( out), DIMENSION(:) :: pvar ! read field 1000 REAL(sp) , INTENT( out), DIMENSION(:) :: pvar ! read field 1001 REAL(dp) , ALLOCATABLE , DIMENSION(:) :: ztmp_pvar ! tmp var to read field 998 1002 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 999 1003 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading … … 1002 1006 ! 1003 1007 IF( kiomid > 0 ) THEN 1008 IF( iom_file(kiomid)%nfid > 0 ) THEN 1009 ALLOCATE(ztmp_pvar(size(pvar,1))) 1010 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=ztmp_pvar, & 1011 & ktime=ktime, kstart=kstart, kcount=kcount, & 1012 & ldxios=ldxios ) 1013 pvar = ztmp_pvar 1014 DEALLOCATE(ztmp_pvar) 1015 END IF 1016 ENDIF 1017 END SUBROUTINE iom_g1d_sp 1018 1019 1020 SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 1021 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1022 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1023 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1024 REAL(dp) , INTENT( out), DIMENSION(:) :: pvar ! read field 1025 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1026 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading 1027 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis 1028 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1029 ! 1030 IF( kiomid > 0 ) THEN 1004 1031 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & 1005 1032 & ktime=ktime, kstart=kstart, kcount=kcount, & 1006 1033 & ldxios=ldxios ) 1007 1034 ENDIF 1008 END SUBROUTINE iom_g1d 1009 1010 SUBROUTINE iom_g2d ( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios)1011 INTEGER , INTENT(in ) 1012 INTEGER , INTENT(in ) 1013 CHARACTER(len=*), INTENT(in ) 1014 REAL( wp) , INTENT( out), DIMENSION(:,:):: pvar ! read field1015 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number1016 INTEGER , INTENT(in ) , DIMENSION(2) , OPTIONAL :: kstart ! start axis position of the reading1017 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kcount ! number of points in each axis1018 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to1019 ! look for and use a file attribute1020 ! called open_ocean_jstart to set the start1021 ! value for the 2nd dimension (netcdf only)1022 LOGICAL , INTENT(in ), OPTIONAL :: ldxios 1035 END SUBROUTINE iom_g1d_dp 1036 1037 SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios) 1038 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1039 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1040 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1041 REAL(sp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1042 REAL(dp) , ALLOCATABLE , DIMENSION(:,:) :: ztmp_pvar ! tmp var to read field 1043 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1044 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1045 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold 1046 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1047 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading 1048 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis 1049 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1023 1050 ! 1024 1051 IF( kiomid > 0 ) THEN 1025 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=pvar, & 1026 & ktime=ktime, kstart=kstart, kcount=kcount, & 1027 & lrowattr=lrowattr, ldxios=ldxios) 1028 ENDIF 1029 END SUBROUTINE iom_g2d 1030 1031 SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios ) 1032 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1033 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1034 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1035 REAL(wp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1036 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1037 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kstart ! start axis position of the reading 1038 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kcount ! number of points in each axis 1039 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 1040 ! look for and use a file attribute 1041 ! called open_ocean_jstart to set the start 1042 ! value for the 2nd dimension (netcdf only) 1043 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1052 IF( iom_file(kiomid)%nfid > 0 ) THEN 1053 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2))) 1054 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = ztmp_pvar , ktime = ktime, & 1055 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1056 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1057 pvar = ztmp_pvar 1058 DEALLOCATE(ztmp_pvar) 1059 ENDIF 1060 ENDIF 1061 END SUBROUTINE iom_g2d_sp 1062 1063 SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios) 1064 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1065 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1066 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1067 REAL(dp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1068 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1069 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1070 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold 1071 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1072 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading 1073 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis 1074 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1044 1075 ! 1045 1076 IF( kiomid > 0 ) THEN 1046 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=pvar, & 1047 & ktime=ktime, kstart=kstart, kcount=kcount, & 1048 & lrowattr=lrowattr, ldxios=ldxios ) 1049 ENDIF 1050 END SUBROUTINE iom_g3d 1077 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = pvar , ktime = ktime, & 1078 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1079 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1080 ENDIF 1081 END SUBROUTINE iom_g2d_dp 1082 1083 SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios ) 1084 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1085 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1086 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1087 REAL(sp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1088 REAL(dp) , ALLOCATABLE , DIMENSION(:,:,:) :: ztmp_pvar ! tmp var to read field 1089 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1090 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1091 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold 1092 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1093 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading 1094 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis 1095 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1096 ! 1097 IF( kiomid > 0 ) THEN 1098 IF( iom_file(kiomid)%nfid > 0 ) THEN 1099 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3))) 1100 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = ztmp_pvar , ktime = ktime, & 1101 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1102 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1103 pvar = ztmp_pvar 1104 DEALLOCATE(ztmp_pvar) 1105 END IF 1106 ENDIF 1107 END SUBROUTINE iom_g3d_sp 1108 1109 SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios ) 1110 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1111 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1112 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1113 REAL(dp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1114 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1115 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1116 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold 1117 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1118 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading 1119 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis 1120 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1121 ! 1122 IF( kiomid > 0 ) THEN 1123 IF( iom_file(kiomid)%nfid > 0 ) THEN 1124 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = pvar , ktime = ktime, & 1125 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1126 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1127 END IF 1128 ENDIF 1129 END SUBROUTINE iom_g3d_dp 1130 1051 1131 !!---------------------------------------------------------------------- 1052 1132 1053 SUBROUTINE iom_get_123d( kiomid, kdom , cdvar , & 1054 & pv_r1d, pv_r2d, pv_r3d, & 1055 & ktime , kstart, kcount, & 1056 & lrowattr, ldxios ) 1133 SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , & 1134 & cd_type, psgn, kfill, kstart, kcount, ldxios ) 1057 1135 !!----------------------------------------------------------------------- 1058 1136 !! *** ROUTINE iom_get_123d *** … … 1062 1140 !! ** Method : read ONE record at each CALL 1063 1141 !!----------------------------------------------------------------------- 1064 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1065 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1066 CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable 1067 REAL(wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 1068 REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 1069 REAL(wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 1070 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 1071 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 1072 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 1073 LOGICAL , INTENT(in ), OPTIONAL :: lrowattr ! logical flag telling iom_get to 1074 ! look for and use a file attribute 1075 ! called open_ocean_jstart to set the start 1076 ! value for the 2nd dimension (netcdf only) 1077 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use XIOS to read restart 1078 ! 1079 LOGICAL :: llxios ! local definition for XIOS read 1080 LOGICAL :: llnoov ! local definition to read overlap 1081 LOGICAL :: luse_jattr ! local definition to read open_ocean_jstart file attribute 1082 INTEGER :: jstartrow ! start point for 2nd dimension optionally set by file attribute 1142 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1143 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1144 CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable 1145 REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 1146 REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 1147 REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 1148 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 1149 CHARACTER(len=1) , INTENT(in ), OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1150 REAL(dp) , INTENT(in ), OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold 1151 INTEGER , INTENT(in ), OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1152 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 1153 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 1154 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use XIOS to read restart 1155 ! 1156 LOGICAL :: llok ! true if ok! 1157 LOGICAL :: llxios ! local definition for XIOS read 1083 1158 INTEGER :: jl ! loop on number of dimension 1084 1159 INTEGER :: idom ! type of domain … … 1096 1171 INTEGER, DIMENSION(jpmax_dims) :: idimsz ! size of the dimensions of the variable 1097 1172 INTEGER, DIMENSION(jpmax_dims) :: ishape ! size of the dimensions of the variable 1098 REAL(wp) :: zscf, zofs ! sacle_factor and add_offset 1173 REAL(dp) :: zscf, zofs ! sacle_factor and add_offset 1174 REAL(wp) :: zsgn ! local value of psgn 1099 1175 INTEGER :: itmp ! temporary integer 1100 1176 CHARACTER(LEN=256) :: clinfo ! info character 1101 1177 CHARACTER(LEN=256) :: clname ! file name 1102 1178 CHARACTER(LEN=1) :: clrankpv, cldmspc ! 1103 LOGICAL :: ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 1179 CHARACTER(LEN=1) :: cl_type ! local value of cd_type 1180 LOGICAL :: ll_only3rd ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 1104 1181 INTEGER :: inlev ! number of levels for 3D data 1105 REAL( wp) :: gma, gmi1182 REAL(dp) :: gma, gmi 1106 1183 !--------------------------------------------------------------------- 1107 1184 ! … … 1110 1187 ! 1111 1188 llxios = .FALSE. 1112 if(PRESENT(ldxios))llxios = ldxios1113 idvar = iom_varid( kiomid, cdvar )1189 IF( PRESENT(ldxios) ) llxios = ldxios 1190 ! 1114 1191 idom = kdom 1192 istop = nstop 1115 1193 ! 1116 1194 IF(.NOT.llxios) THEN 1117 1195 clname = iom_file(kiomid)%name ! esier to read 1118 1196 clinfo = ' iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) 1119 ! local definition of the domain ?1120 ! do we read the overlap1121 ! ugly patch SM+JMM+RB to overwrite global definition in some cases1122 llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif1123 1197 ! check kcount and kstart optionals parameters... 1124 IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present') 1125 IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 1126 IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND. idom /= jpdom_autoglo_xy ) & 1127 & CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown or kdom = jpdom_autoglo_xy') 1128 1129 luse_jattr = .false. 1130 IF( PRESENT(lrowattr) ) THEN 1131 IF( lrowattr .AND. idom /= jpdom_data ) CALL ctl_stop(trim(clinfo), 'lrowattr present and true needs kdom = jpdom_data') 1132 IF( lrowattr .AND. idom == jpdom_data ) luse_jattr = .true. 1133 ENDIF 1134 1198 IF( PRESENT(kcount) .AND. .NOT. PRESENT(kstart) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present') 1199 IF( PRESENT(kstart) .AND. .NOT. PRESENT(kcount) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 1200 IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND. idom /= jpdom_auto_xy ) & 1201 & CALL ctl_stop(TRIM(clinfo), 'kstart present needs idom = jpdom_unknown or idom = jpdom_auto_xy') 1202 IF( idom == jpdom_auto_xy .AND. .NOT. PRESENT(kstart) ) & 1203 & CALL ctl_stop(TRIM(clinfo), 'idom = jpdom_auto_xy requires kstart to be present') 1204 ! 1135 1205 ! Search for the variable in the data base (eventually actualize data) 1136 istop = nstop1137 1206 ! 1207 idvar = iom_varid( kiomid, cdvar ) 1138 1208 IF( idvar > 0 ) THEN 1139 ! to write iom_file(kiomid)%dimsz in a shorter way !1140 idimsz(:) = iom_file(kiomid)%dimsz(:, idvar) 1209 ! 1210 idimsz(:) = iom_file(kiomid)%dimsz(:, idvar) ! to write iom_file(kiomid)%dimsz in a shorter way 1141 1211 inbdim = iom_file(kiomid)%ndims(idvar) ! number of dimensions in the file 1142 1212 idmspc = inbdim ! number of spatial dimensions in the file … … 1144 1214 IF( idmspc > 3 ) CALL ctl_stop(trim(clinfo), 'the file has more than 3 spatial dimensions this case is not coded...') 1145 1215 ! 1146 ! update idom definition... 1147 ! Identify the domain in case of jpdom_auto(glo/dta) definition 1148 IF( idom == jpdom_autoglo_xy ) THEN 1149 ll_depth_spec = .TRUE. 1150 idom = jpdom_autoglo 1151 ELSE 1152 ll_depth_spec = .FALSE. 1153 ENDIF 1154 IF( idom == jpdom_autoglo .OR. idom == jpdom_autodta ) THEN 1155 IF( idom == jpdom_autoglo ) THEN ; idom = jpdom_global 1156 ELSE ; idom = jpdom_data 1157 ENDIF 1216 ! Identify the domain in case of jpdom_auto definition 1217 IF( idom == jpdom_auto .OR. idom == jpdom_auto_xy ) THEN 1218 idom = jpdom_global ! default 1219 ! else: if the file name finishes with _xxxx.nc with xxxx any number 1158 1220 ind1 = INDEX( clname, '_', back = .TRUE. ) + 1 1159 1221 ind2 = INDEX( clname, '.', back = .TRUE. ) - 1 1160 1222 IF( ind2 > ind1 ) THEN ; IF( VERIFY( clname(ind1:ind2), '0123456789' ) == 0 ) idom = jpdom_local ; ENDIF 1161 ENDIF1162 ! Identify the domain in case of jpdom_local definition1163 IF( idom == jpdom_local ) THEN1164 IF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN ; idom = jpdom_local_full1165 ELSEIF( idimsz(1) == nlci .AND. idimsz(2) == nlcj ) THEN ; idom = jpdom_local_noextra1166 ELSEIF( idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1) ) THEN ; idom = jpdom_local_noovlap1167 ELSE ; CALL ctl_stop( trim(clinfo), 'impossible to identify the local domain' )1168 ENDIF1169 1223 ENDIF 1170 1224 ! … … 1179 1233 WRITE(cldmspc , fmt='(i1)') idmspc 1180 1234 ! 1181 !!GS: we consider 2D data as 3D data with vertical dim size = 1 1182 !IF( idmspc < irankpv ) THEN 1183 ! CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension', & 1184 ! & 'it is impossible to read a '//clrankpv//'D array from this file...' ) 1185 !ELSEIF( idmspc == irankpv ) THEN 1186 IF( idmspc == irankpv ) THEN 1235 IF( idmspc < irankpv ) THEN ! it seems we want to read more than we can... 1236 IF( irankpv == 3 .AND. idmspc == 2 ) THEN ! 3D input array from 2D spatial data in the file: 1237 llok = inlev == 1 ! -> 3rd dimension must be equal to 1 1238 ELSEIF( irankpv == 3 .AND. idmspc == 1 ) THEN ! 3D input array from 1D spatial data in the file: 1239 llok = inlev == 1 .AND. SIZE(pv_r3d, 2) == 1 ! -> 2nd and 3rd dimensions must be equal to 1 1240 ELSEIF( irankpv == 2 .AND. idmspc == 2 ) THEN ! 2D input array from 1D spatial data in the file: 1241 llok = SIZE(pv_r2d, 2) == 1 ! -> 2nd dimension must be equal to 1 1242 ELSE 1243 llok = .FALSE. 1244 ENDIF 1245 IF( .NOT. llok ) CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension', & 1246 & '=> cannot read a true '//clrankpv//'D array from this file...' ) 1247 ELSEIF( idmspc == irankpv ) THEN 1187 1248 IF( PRESENT(pv_r1d) .AND. idom /= jpdom_unknown ) & 1188 1249 & CALL ctl_stop( TRIM(clinfo), 'case not coded...You must use jpdom_unknown' ) 1189 ELSEIF( idmspc > irankpv ) THEN 1250 ELSEIF( idmspc > irankpv ) THEN ! it seems we want to read less than we should... 1190 1251 IF( PRESENT(pv_r2d) .AND. itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN 1191 CALL ctl_warn( trim(clinfo), '2D array but 3 spatial dimensions for the data...' , &1252 CALL ctl_warn( trim(clinfo), '2D array input but 3 spatial dimensions in the file...' , & 1192 1253 & 'As the size of the z dimension is 1 and as we try to read the first record, ', & 1193 1254 & 'we accept this case, even if there is a possible mix-up between z and time dimension' ) 1194 1255 idmspc = idmspc - 1 1195 ELSE 1196 CALL ctl_stop( TRIM(clinfo), 'To keep iom lisibility, when reading a '//clrankpv//'D array,' , & 1197 & 'we do not accept data with '//cldmspc//' spatial dimensions', & 1198 & 'Use ncwa -a to suppress the unnecessary dimensions' ) 1256 !!GS: possibility to read 3D ABL atmopsheric forcing and use 1st level to force BULK simulation 1257 !ELSE 1258 ! CALL ctl_stop( TRIM(clinfo), 'To keep iom lisibility, when reading a '//clrankpv//'D array,', & 1259 ! & 'we do not accept data with '//cldmspc//' spatial dimensions' , & 1260 ! & 'Use ncwa -a to suppress the unnecessary dimensions' ) 1199 1261 ENDIF 1200 1262 ENDIF … … 1202 1264 ! definition of istart and icnt 1203 1265 ! 1204 icnt (:) = 1 1205 istart(:) = 1 1206 istart(idmspc+1) = itime 1207 1208 IF( PRESENT(kstart) .AND. .NOT. ll_depth_spec ) THEN 1209 istart(1:idmspc) = kstart(1:idmspc) 1210 icnt (1:idmspc) = kcount(1:idmspc) 1211 ELSE 1212 IF(idom == jpdom_unknown ) THEN 1213 icnt(1:idmspc) = idimsz(1:idmspc) 1214 ELSE 1215 IF( .NOT. PRESENT(pv_r1d) ) THEN ! not a 1D array 1216 IF( idom == jpdom_data ) THEN 1217 jstartrow = 1 1218 IF( luse_jattr ) THEN 1219 CALL iom_getatt(kiomid, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 1220 jstartrow = MAX(1,jstartrow) 1221 ENDIF 1222 istart(1:2) = (/ mig(1), mjg(1) + jstartrow - 1 /) ! icnt(1:2) done below 1223 ELSEIF( idom == jpdom_global ) THEN ; istart(1:2) = (/ nimpp , njmpp /) ! icnt(1:2) done below 1224 ENDIF 1225 ! we do not read the overlap -> we start to read at nldi, nldj 1226 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1227 ! IF( idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) 1228 IF( llnoov .AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) 1229 ! we do not read the overlap and the extra-halos -> from nldi to nlei and from nldj to nlej 1230 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1231 ! icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) 1232 IF( llnoov ) THEN ; icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) 1233 ELSE ; icnt(1:2) = (/ nlci , nlcj /) 1234 ENDIF 1235 IF( PRESENT(pv_r3d) ) THEN 1236 IF( idom == jpdom_data ) THEN ; icnt(3) = inlev 1237 ELSEIF( ll_depth_spec .AND. PRESENT(kstart) ) THEN ; istart(3) = kstart(3) ; icnt(3) = kcount(3) 1238 ELSE ; icnt(3) = inlev 1239 ENDIF 1240 ENDIF 1266 icnt (:) = 1 ! default definition (simple way to deal with special cases listed above) 1267 istart(:) = 1 ! default definition (simple way to deal with special cases listed above) 1268 istart(idmspc+1) = itime ! temporal dimenstion 1269 ! 1270 IF( idom == jpdom_unknown ) THEN 1271 IF( PRESENT(kstart) .AND. idom /= jpdom_auto_xy ) THEN 1272 istart(1:idmspc) = kstart(1:idmspc) 1273 icnt (1:idmspc) = kcount(1:idmspc) 1274 ELSE 1275 icnt (1:idmspc) = idimsz(1:idmspc) 1276 ENDIF 1277 ELSE ! not a 1D array as pv_r1d requires jpdom_unknown 1278 ! we do not read the overlap and the extra-halos -> from Nis0 to Nie0 and from Njs0 to Nje0 1279 IF( idom == jpdom_global ) istart(1:2) = (/ mig0(Nis0), mjg0(Njs0) /) 1280 icnt(1:2) = (/ Ni_0, Nj_0 /) 1281 IF( PRESENT(pv_r3d) ) THEN 1282 IF( idom == jpdom_auto_xy ) THEN 1283 istart(3) = kstart(3) 1284 icnt (3) = kcount(3) 1285 ELSE 1286 icnt (3) = inlev 1241 1287 ENDIF 1242 1288 ENDIF 1243 1289 ENDIF 1244 1290 ! 1245 1291 ! check that istart and icnt can be used with this file 1246 1292 !- … … 1253 1299 ENDIF 1254 1300 END DO 1255 1301 ! 1256 1302 ! check that icnt matches the input array 1257 1303 !- … … 1263 1309 ELSE 1264 1310 IF( irankpv == 2 ) THEN 1265 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1266 ! ishape(1:2) = SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1 = 'd(nldi:nlei,nldj:nlej)' 1267 IF( llnoov ) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1='d(nldi:nlei,nldj:nlej)' 1268 ELSE ; ishape(1:2)=SHAPE(pv_r2d(1 :nlci,1 :nlcj )) ; ctmp1='d(1:nlci,1:nlcj)' 1269 ENDIF 1311 ishape(1:2) = SHAPE(pv_r2d(Nis0:Nie0,Njs0:Nje0 )) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0)' 1270 1312 ENDIF 1271 1313 IF( irankpv == 3 ) THEN 1272 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1273 ! ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1 = 'd(nldi:nlei,nldj:nlej,:)' 1274 IF( llnoov ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)' 1275 ELSE ; ishape(1:3)=SHAPE(pv_r3d(1 :nlci,1 :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)' 1276 ENDIF 1314 ishape(1:3) = SHAPE(pv_r3d(Nis0:Nie0,Njs0:Nje0,:)) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0,:)' 1277 1315 ENDIF 1278 ENDIF 1279 1316 ENDIF 1280 1317 DO jl = 1, irankpv 1281 1318 WRITE( ctmp2, FMT="(', ', i1,'): ', i5,' /= icnt(', i1,'):', i5)" ) jl, ishape(jl), jl, icnt(jl) … … 1289 1326 IF( idvar > 0 .AND. istop == nstop ) THEN ! no additional errors until this point... 1290 1327 ! 1291 ! find the right index of the array to be read 1292 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1293 ! IF( idom /= jpdom_unknown ) THEN ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej 1294 ! ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 1295 ! ENDIF 1296 IF( llnoov ) THEN 1297 IF( idom /= jpdom_unknown ) THEN ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej 1298 ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 1299 ENDIF 1300 ELSE 1301 IF( idom /= jpdom_unknown ) THEN ; ix1 = 1 ; ix2 = nlci ; iy1 = 1 ; iy2 = nlcj 1302 ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 1303 ENDIF 1328 ! find the right index of the array to be read 1329 IF( idom /= jpdom_unknown ) THEN ; ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0 1330 ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 1304 1331 ENDIF 1305 1332 … … 1308 1335 IF( istop == nstop ) THEN ! no additional errors until this point... 1309 1336 IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i6,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name) 1310 1337 1338 cl_type = 'T' 1339 IF( PRESENT(cd_type) ) cl_type = cd_type 1340 zsgn = 1._wp 1341 IF( PRESENT(psgn ) ) zsgn = psgn 1311 1342 !--- overlap areas and extra hallows (mpp) 1312 IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 1313 CALL lbc_lnk( 'iom', pv_r2d,'Z', -999., kfillmode = jpfillnothing ) 1314 ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN 1315 ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 1316 IF( icnt(3) == inlev ) THEN 1317 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing ) 1318 ELSE ! put some arbitrary value (a call to lbc_lnk will be done later...) 1319 DO jj = nlcj+1, jpj ; pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :) ; END DO 1320 DO ji = nlci+1, jpi ; pv_r3d(ji , : , :) = pv_r3d(nlei , : , :) ; END DO 1321 ENDIF 1343 IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN 1344 CALL lbc_lnk( 'iom', pv_r2d, cl_type, zsgn, kfillmode = kfill ) 1345 ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN 1346 CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill ) 1322 1347 ENDIF 1323 1348 ! … … 1336 1361 CALL iom_swap( TRIM(crxios_context) ) 1337 1362 IF( PRESENT(pv_r3d) ) THEN 1338 pv_r3d(:, :, :) = 0. 1339 if(lwp) write(numout,*) 'XIOS RST READ (3D): ',trim(cdvar) 1363 IF(lwp) WRITE(numout,*) 'XIOS RST READ (3D): ',TRIM(cdvar) 1340 1364 CALL xios_recv_field( trim(cdvar), pv_r3d) 1341 IF(idom /= jpdom_unknown ) then 1342 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) 1343 ENDIF 1365 IF(idom /= jpdom_unknown ) CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) 1344 1366 ELSEIF( PRESENT(pv_r2d) ) THEN 1345 pv_r2d(:, :) = 0. 1346 if(lwp) write(numout,*) 'XIOS RST READ (2D): ', trim(cdvar) 1367 IF(lwp) WRITE(numout,*) 'XIOS RST READ (2D): ', TRIM(cdvar) 1347 1368 CALL xios_recv_field( trim(cdvar), pv_r2d) 1348 IF(idom /= jpdom_unknown ) THEN 1349 CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) 1350 ENDIF 1369 IF(idom /= jpdom_unknown ) CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) 1351 1370 ELSEIF( PRESENT(pv_r1d) ) THEN 1352 pv_r1d(:) = 0. 1353 if(lwp) write(numout,*) 'XIOS RST READ (1D): ', trim(cdvar) 1371 IF(lwp) WRITE(numout,*) 'XIOS RST READ (1D): ', TRIM(cdvar) 1354 1372 CALL xios_recv_field( trim(cdvar), pv_r1d) 1355 1373 ENDIF … … 1362 1380 !some final adjustments 1363 1381 ! C1D case : always call lbc_lnk to replicate the central value over the whole 3X3 domain 1364 IF( lk_c1d .AND. PRESENT(pv_r2d) ) CALL lbc_lnk( 'iom', pv_r2d,'Z',1. )1365 IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1. )1382 IF( lk_c1d .AND. PRESENT(pv_r2d) ) CALL lbc_lnk( 'iom', pv_r2d,'Z',1.0_wp ) 1383 IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1.0_wp ) 1366 1384 1367 1385 !--- Apply scale_factor and offset … … 1550 1568 !! INTERFACE iom_rstput 1551 1569 !!---------------------------------------------------------------------- 1552 SUBROUTINE iom_rp0d ( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1570 SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1553 1571 INTEGER , INTENT(in) :: kt ! ocean time-step 1554 1572 INTEGER , INTENT(in) :: kwrite ! writing time-step 1555 1573 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1556 1574 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1557 REAL( wp) , INTENT(in) :: pvar ! written field1575 REAL(sp) , INTENT(in) :: pvar ! written field 1558 1576 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1559 1577 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1574 1592 IF( iom_file(kiomid)%nfid > 0 ) THEN 1575 1593 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1576 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar)1594 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = real(pvar, dp) ) 1577 1595 ENDIF 1578 1596 ENDIF 1579 1597 ENDIF 1580 END SUBROUTINE iom_rp0d 1581 1582 SUBROUTINE iom_rp 1d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1598 END SUBROUTINE iom_rp0d_sp 1599 1600 SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1583 1601 INTEGER , INTENT(in) :: kt ! ocean time-step 1584 1602 INTEGER , INTENT(in) :: kwrite ! writing time-step 1585 1603 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1586 1604 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1587 REAL(wp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1605 REAL(dp) , INTENT(in) :: pvar ! written field 1606 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1607 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1608 LOGICAL :: llx ! local xios write flag 1609 INTEGER :: ivid ! variable id 1610 1611 llx = .FALSE. 1612 IF(PRESENT(ldxios)) llx = ldxios 1613 IF( llx ) THEN 1614 #ifdef key_iomput 1615 IF( kt == kwrite ) THEN 1616 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1617 CALL xios_send_field(trim(cdvar), pvar) 1618 ENDIF 1619 #endif 1620 ELSE 1621 IF( kiomid > 0 ) THEN 1622 IF( iom_file(kiomid)%nfid > 0 ) THEN 1623 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1624 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) 1625 ENDIF 1626 ENDIF 1627 ENDIF 1628 END SUBROUTINE iom_rp0d_dp 1629 1630 1631 SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1632 INTEGER , INTENT(in) :: kt ! ocean time-step 1633 INTEGER , INTENT(in) :: kwrite ! writing time-step 1634 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1635 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1636 REAL(sp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1588 1637 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1589 1638 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1604 1653 IF( iom_file(kiomid)%nfid > 0 ) THEN 1605 1654 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1606 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar)1655 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = real(pvar, dp) ) 1607 1656 ENDIF 1608 1657 ENDIF 1609 1658 ENDIF 1610 END SUBROUTINE iom_rp1d 1611 1612 SUBROUTINE iom_rp 2d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1659 END SUBROUTINE iom_rp1d_sp 1660 1661 SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1613 1662 INTEGER , INTENT(in) :: kt ! ocean time-step 1614 1663 INTEGER , INTENT(in) :: kwrite ! writing time-step 1615 1664 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1616 1665 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1617 REAL(wp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1666 REAL(dp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1667 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1668 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1669 LOGICAL :: llx ! local xios write flag 1670 INTEGER :: ivid ! variable id 1671 1672 llx = .FALSE. 1673 IF(PRESENT(ldxios)) llx = ldxios 1674 IF( llx ) THEN 1675 #ifdef key_iomput 1676 IF( kt == kwrite ) THEN 1677 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1678 CALL xios_send_field(trim(cdvar), pvar) 1679 ENDIF 1680 #endif 1681 ELSE 1682 IF( kiomid > 0 ) THEN 1683 IF( iom_file(kiomid)%nfid > 0 ) THEN 1684 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1685 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) 1686 ENDIF 1687 ENDIF 1688 ENDIF 1689 END SUBROUTINE iom_rp1d_dp 1690 1691 1692 SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1693 INTEGER , INTENT(in) :: kt ! ocean time-step 1694 INTEGER , INTENT(in) :: kwrite ! writing time-step 1695 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1696 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1697 REAL(sp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1618 1698 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1619 1699 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1634 1714 IF( iom_file(kiomid)%nfid > 0 ) THEN 1635 1715 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1636 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar)1716 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = real(pvar, dp) ) 1637 1717 ENDIF 1638 1718 ENDIF 1639 1719 ENDIF 1640 END SUBROUTINE iom_rp2d 1641 1642 SUBROUTINE iom_rp 3d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1720 END SUBROUTINE iom_rp2d_sp 1721 1722 SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1643 1723 INTEGER , INTENT(in) :: kt ! ocean time-step 1644 1724 INTEGER , INTENT(in) :: kwrite ! writing time-step 1645 1725 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1646 1726 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1647 REAL(wp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1727 REAL(dp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1728 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1729 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1730 LOGICAL :: llx 1731 INTEGER :: ivid ! variable id 1732 1733 llx = .FALSE. 1734 IF(PRESENT(ldxios)) llx = ldxios 1735 IF( llx ) THEN 1736 #ifdef key_iomput 1737 IF( kt == kwrite ) THEN 1738 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1739 CALL xios_send_field(trim(cdvar), pvar) 1740 ENDIF 1741 #endif 1742 ELSE 1743 IF( kiomid > 0 ) THEN 1744 IF( iom_file(kiomid)%nfid > 0 ) THEN 1745 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1746 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) 1747 ENDIF 1748 ENDIF 1749 ENDIF 1750 END SUBROUTINE iom_rp2d_dp 1751 1752 1753 SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1754 INTEGER , INTENT(in) :: kt ! ocean time-step 1755 INTEGER , INTENT(in) :: kwrite ! writing time-step 1756 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1757 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1758 REAL(sp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1648 1759 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1649 1760 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1664 1775 IF( iom_file(kiomid)%nfid > 0 ) THEN 1665 1776 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1777 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = real(pvar, dp) ) 1778 ENDIF 1779 ENDIF 1780 ENDIF 1781 END SUBROUTINE iom_rp3d_sp 1782 1783 SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1784 INTEGER , INTENT(in) :: kt ! ocean time-step 1785 INTEGER , INTENT(in) :: kwrite ! writing time-step 1786 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1787 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1788 REAL(dp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1789 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1790 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1791 LOGICAL :: llx ! local xios write flag 1792 INTEGER :: ivid ! variable id 1793 1794 llx = .FALSE. 1795 IF(PRESENT(ldxios)) llx = ldxios 1796 IF( llx ) THEN 1797 #ifdef key_iomput 1798 IF( kt == kwrite ) THEN 1799 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1800 CALL xios_send_field(trim(cdvar), pvar) 1801 ENDIF 1802 #endif 1803 ELSE 1804 IF( kiomid > 0 ) THEN 1805 IF( iom_file(kiomid)%nfid > 0 ) THEN 1806 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1666 1807 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) 1667 1808 ENDIF 1668 1809 ENDIF 1669 1810 ENDIF 1670 END SUBROUTINE iom_rp3d 1811 END SUBROUTINE iom_rp3d_dp 1812 1671 1813 1672 1814 … … 1720 1862 !! INTERFACE iom_put 1721 1863 !!---------------------------------------------------------------------- 1722 SUBROUTINE iom_p0d ( cdname, pfield0d )1864 SUBROUTINE iom_p0d_sp( cdname, pfield0d ) 1723 1865 CHARACTER(LEN=*), INTENT(in) :: cdname 1724 REAL( wp) , INTENT(in) :: pfield0d1866 REAL(sp) , INTENT(in) :: pfield0d 1725 1867 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1726 1868 #if defined key_iomput … … 1731 1873 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings 1732 1874 #endif 1733 END SUBROUTINE iom_p0d 1734 1735 SUBROUTINE iom_p1d( cdname, pfield1d ) 1875 END SUBROUTINE iom_p0d_sp 1876 1877 SUBROUTINE iom_p0d_dp( cdname, pfield0d ) 1878 CHARACTER(LEN=*), INTENT(in) :: cdname 1879 REAL(dp) , INTENT(in) :: pfield0d 1880 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1881 #if defined key_iomput 1882 !!clem zz(:,:)=pfield0d 1883 !!clem CALL xios_send_field(cdname, zz) 1884 CALL xios_send_field(cdname, (/pfield0d/)) 1885 #else 1886 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings 1887 #endif 1888 END SUBROUTINE iom_p0d_dp 1889 1890 1891 SUBROUTINE iom_p1d_sp( cdname, pfield1d ) 1736 1892 CHARACTER(LEN=*) , INTENT(in) :: cdname 1737 REAL( wp), DIMENSION(:), INTENT(in) :: pfield1d1893 REAL(sp), DIMENSION(:), INTENT(in) :: pfield1d 1738 1894 #if defined key_iomput 1739 1895 CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) … … 1741 1897 IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings 1742 1898 #endif 1743 END SUBROUTINE iom_p1d 1744 1745 SUBROUTINE iom_p2d( cdname, pfield2d ) 1899 END SUBROUTINE iom_p1d_sp 1900 1901 SUBROUTINE iom_p1d_dp( cdname, pfield1d ) 1902 CHARACTER(LEN=*) , INTENT(in) :: cdname 1903 REAL(dp), DIMENSION(:), INTENT(in) :: pfield1d 1904 #if defined key_iomput 1905 CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) 1906 #else 1907 IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings 1908 #endif 1909 END SUBROUTINE iom_p1d_dp 1910 1911 SUBROUTINE iom_p2d_sp( cdname, pfield2d ) 1746 1912 CHARACTER(LEN=*) , INTENT(in) :: cdname 1747 REAL(wp), DIMENSION(:,:), INTENT(in) :: pfield2d 1748 #if defined key_iomput 1749 CALL xios_send_field(cdname, pfield2d) 1913 REAL(sp), DIMENSION(:,:), INTENT(in) :: pfield2d 1914 IF( iom_use(cdname) ) THEN 1915 #if defined key_iomput 1916 IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 1917 CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d 1918 ELSE 1919 CALL xios_send_field( cdname, pfield2d ) 1920 ENDIF 1750 1921 #else 1751 IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings 1752 #endif 1753 END SUBROUTINE iom_p2d 1754 1755 SUBROUTINE iom_p3d( cdname, pfield3d ) 1922 WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1923 #endif 1924 ENDIF 1925 END SUBROUTINE iom_p2d_sp 1926 1927 SUBROUTINE iom_p2d_dp( cdname, pfield2d ) 1928 CHARACTER(LEN=*) , INTENT(in) :: cdname 1929 REAL(dp), DIMENSION(:,:), INTENT(in) :: pfield2d 1930 IF( iom_use(cdname) ) THEN 1931 #if defined key_iomput 1932 IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 1933 CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d 1934 ELSE 1935 CALL xios_send_field( cdname, pfield2d ) 1936 ENDIF 1937 #else 1938 WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1939 #endif 1940 ENDIF 1941 END SUBROUTINE iom_p2d_dp 1942 1943 SUBROUTINE iom_p3d_sp( cdname, pfield3d ) 1756 1944 CHARACTER(LEN=*) , INTENT(in) :: cdname 1757 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 1758 #if defined key_iomput 1759 CALL xios_send_field( cdname, pfield3d ) 1945 REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 1946 IF( iom_use(cdname) ) THEN 1947 #if defined key_iomput 1948 IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 1949 CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d 1950 ELSE 1951 CALL xios_send_field( cdname, pfield3d ) 1952 ENDIF 1760 1953 #else 1761 IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings 1762 #endif 1763 END SUBROUTINE iom_p3d 1764 1765 SUBROUTINE iom_p4d( cdname, pfield4d ) 1954 WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1955 #endif 1956 ENDIF 1957 END SUBROUTINE iom_p3d_sp 1958 1959 SUBROUTINE iom_p3d_dp( cdname, pfield3d ) 1766 1960 CHARACTER(LEN=*) , INTENT(in) :: cdname 1767 REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 1768 #if defined key_iomput 1769 CALL xios_send_field(cdname, pfield4d) 1961 REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 1962 IF( iom_use(cdname) ) THEN 1963 #if defined key_iomput 1964 IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 1965 CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d 1966 ELSE 1967 CALL xios_send_field( cdname, pfield3d ) 1968 ENDIF 1770 1969 #else 1771 IF( .FALSE. ) WRITE(numout,*) cdname, pfield4d ! useless test to avoid compilation warnings 1772 #endif 1773 END SUBROUTINE iom_p4d 1774 1970 WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1971 #endif 1972 ENDIF 1973 END SUBROUTINE iom_p3d_dp 1974 1975 SUBROUTINE iom_p4d_sp( cdname, pfield4d ) 1976 CHARACTER(LEN=*) , INTENT(in) :: cdname 1977 REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 1978 IF( iom_use(cdname) ) THEN 1979 #if defined key_iomput 1980 IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 1981 CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d 1982 ELSE 1983 CALL xios_send_field (cdname, pfield4d ) 1984 ENDIF 1985 #else 1986 WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1987 #endif 1988 ENDIF 1989 END SUBROUTINE iom_p4d_sp 1990 1991 SUBROUTINE iom_p4d_dp( cdname, pfield4d ) 1992 CHARACTER(LEN=*) , INTENT(in) :: cdname 1993 REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 1994 IF( iom_use(cdname) ) THEN 1995 #if defined key_iomput 1996 IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 1997 CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d 1998 ELSE 1999 CALL xios_send_field (cdname, pfield4d ) 2000 ENDIF 2001 #else 2002 WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 2003 #endif 2004 ENDIF 2005 END SUBROUTINE iom_p4d_dp 1775 2006 1776 2007 #if defined key_iomput … … 1788 2019 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1789 2020 INTEGER , OPTIONAL, INTENT(in) :: nvertex 1790 REAL( wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue1791 REAL( wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area2021 REAL(dp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 2022 REAL(dp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1792 2023 LOGICAL , DIMENSION(:) , OPTIONAL, INTENT(in) :: mask 1793 2024 !!---------------------------------------------------------------------- … … 1852 2083 !!---------------------------------------------------------------------- 1853 2084 IF( PRESENT(paxis) ) THEN 1854 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=paxis ) 1855 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 1856 ENDIF 1857 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=bounds ) 1858 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 2085 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 2086 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 2087 ENDIF 2088 IF( PRESENT(bounds) ) THEN 2089 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=real(bounds, dp) ) 2090 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=real(bounds, dp) ) 2091 ELSE 2092 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid) 2093 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid) 2094 END IF 1859 2095 CALL xios_solve_inheritance() 1860 2096 END SUBROUTINE iom_set_axis_attr … … 1963 2199 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat 1964 2200 ! 1965 INTEGER :: ni, nj1966 2201 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask 1967 2202 LOGICAL, INTENT(IN) :: ldxios, ldrxios 1968 2203 !!---------------------------------------------------------------------- 1969 2204 ! 1970 ni = nlei-nldi+1 1971 nj = nlej-nldj+1 1972 ! 1973 CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 1974 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 2205 CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=Ni0glo,nj_glo=Nj0glo,ibegin=mig0(Nis0)-1,jbegin=mjg0(Njs0)-1,ni=Ni_0,nj=Nj_0) 2206 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0) 1975 2207 !don't define lon and lat for restart reading context. 1976 2208 IF ( .NOT.ldrxios ) & 1977 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), &1978 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))2209 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = real(RESHAPE(plon(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp), & 2210 & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp )) 1979 2211 ! 1980 2212 IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN … … 1982 2214 SELECT CASE ( cdgrd ) 1983 2215 CASE('T') ; zmask(:,:,:) = tmask(:,:,:) 1984 CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( 'iom', zmask, 'U', 1. )1985 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( 'iom', zmask, 'V', 1. )2216 CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) 2217 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) 1986 2218 CASE('W') ; zmask(:,:,2:jpk ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk) ; zmask(:,:,1) = tmask(:,:,1) 1987 2219 END SELECT 1988 2220 ! 1989 CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask( nldi:nlei,nldj:nlej,1),(/ni*nj/)) /= 0. )1990 CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask( nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. )2221 CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask(Nis0:Nie0,Njs0:Nje0,1),(/Ni_0*Nj_0 /)) /= 0. ) 2222 CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(Nis0:Nie0,Njs0:Nje0,:),(/Ni_0,Nj_0,jpk/)) /= 0. ) 1991 2223 ENDIF 1992 2224 ! 1993 2225 END SUBROUTINE set_grid 1994 1995 2226 1996 2227 SUBROUTINE set_grid_bounds( cdgrd, plon_cnr, plat_cnr, plon_pnt, plat_pnt ) … … 2005 2236 REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coord. of the point of cell (i,j) 2006 2237 ! 2007 INTEGER :: ji, jj, jn , ni, nj2238 INTEGER :: ji, jj, jn 2008 2239 INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 2009 ! ! represents the bottom-left corner of cell (i,j) 2240 ! ! represents the 2241 ! bottom-left corner of 2242 ! cell (i,j) 2010 2243 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j) 2011 2244 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells … … 2022 2255 END SELECT 2023 2256 ! 2024 ni = nlei-nldi+1 ! Dimensions of subdomain interior2025 nj = nlej-nldj+12026 !2027 2257 z_fld(:,:) = 1._wp 2028 CALL lbc_lnk( 'iom', z_fld, cdgrd, -1. ) ! Working array for location of northfold2258 CALL lbc_lnk( 'iom', z_fld, cdgrd, -1.0_wp ) ! Working array for location of northfold 2029 2259 ! 2030 2260 ! Cell vertices that can be defined 2031 DO jj = 2, jpjm1 2032 DO ji = 2, jpim1 2033 z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 2034 z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 2035 z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 2036 z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr+1) ! Top-left 2037 z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 2038 z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 2039 z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 2040 z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr+1) ! Top-left 2041 END DO 2042 END DO 2043 ! 2044 ! Cell vertices on boundries 2045 DO jn = 1, 4 2046 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1., pfillval=999._wp ) 2047 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1., pfillval=999._wp ) 2048 END DO 2049 ! 2050 ! Zero-size cells at closed boundaries if cell points provided, 2051 ! otherwise they are closed cells with unrealistic bounds 2052 IF( PRESENT(plon_pnt) .AND. PRESENT(plat_pnt) ) THEN 2053 IF( (nbondi == -1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 2054 DO jn = 1, 4 ! (West or jpni = 1), closed E-W 2055 z_bnds(jn,1,:,1) = plat_pnt(1,:) ; z_bnds(jn,1,:,2) = plon_pnt(1,:) 2056 END DO 2057 ENDIF 2058 IF( (nbondi == 1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 2059 DO jn = 1, 4 ! (East or jpni = 1), closed E-W 2060 z_bnds(jn,nlci,:,1) = plat_pnt(nlci,:) ; z_bnds(jn,nlci,:,2) = plon_pnt(nlci,:) 2061 END DO 2062 ENDIF 2063 IF( nbondj == -1 .OR. (nbondj == 2 .AND. jperio /= 2) ) THEN 2064 DO jn = 1, 4 ! South or (jpnj = 1, not symmetric) 2065 z_bnds(jn,:,1,1) = plat_pnt(:,1) ; z_bnds(jn,:,1,2) = plon_pnt(:,1) 2066 END DO 2067 ENDIF 2068 IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio < 3 ) THEN 2069 DO jn = 1, 4 ! (North or jpnj = 1), no north fold 2070 z_bnds(jn,:,nlcj,1) = plat_pnt(:,nlcj) ; z_bnds(jn,:,nlcj,2) = plon_pnt(:,nlcj) 2071 END DO 2072 ENDIF 2073 ENDIF 2074 ! 2075 IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio >= 3 ) THEN ! Rotate cells at the north fold 2076 DO jj = 1, jpj 2077 DO ji = 1, jpi 2078 IF( z_fld(ji,jj) == -1. ) THEN 2079 z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:) 2080 z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:) 2081 z_bnds(:,ji,jj,:) = z_rot(:,:) 2082 ENDIF 2083 END DO 2084 END DO 2085 ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN ! Invert cells at the symmetric equator 2086 DO ji = 1, jpi 2087 z_rot(1:2,:) = z_bnds(3:4,ji,1,:) 2088 z_rot(3:4,:) = z_bnds(1:2,ji,1,:) 2089 z_bnds(:,ji,1,:) = z_rot(:,:) 2090 END DO 2091 ENDIF 2092 ! 2093 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), & 2094 & bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 ) 2095 ! 2096 DEALLOCATE( z_bnds, z_fld, z_rot ) 2261 DO_2D( 0, 0, 0, 0 ) 2262 z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 2263 z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 2264 z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 2265 z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr+1) ! Top-left 2266 z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 2267 z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 2268 z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 2269 z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr+1) ! Top-left 2270 END_2D 2271 ! 2272 DO_2D( 0, 0, 0, 0 ) 2273 IF( z_fld(ji,jj) == -1. ) THEN 2274 z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:) 2275 z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:) 2276 z_bnds(:,ji,jj,:) = z_rot(:,:) 2277 ENDIF 2278 END_2D 2279 ! 2280 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,1),(/ 4,Ni_0*Nj_0 /)), dp), & 2281 & bounds_lon = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,2),(/ 4,Ni_0*Nj_0 /)), dp), nvertex=4 ) 2282 ! 2283 DEALLOCATE( z_bnds, z_fld, z_rot ) 2097 2284 ! 2098 2285 END SUBROUTINE set_grid_bounds 2099 2286 2100 2101 2287 SUBROUTINE set_grid_znl( plat ) 2102 2288 !!---------------------------------------------------------------------- … … 2108 2294 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat 2109 2295 ! 2110 INTEGER :: ni, nj,ix, iy2296 INTEGER :: ix, iy 2111 2297 REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon 2112 2298 !!---------------------------------------------------------------------- 2113 2299 ! 2114 ni=nlei-nldi+1 ! define zonal mean domain (jpj*jpk) 2115 nj=nlej-nldj+1 2116 ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0._wp 2117 ! 2118 ! CALL dom_ngb( -168.53, 65.03, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) 2119 CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 2120 CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 2121 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 2122 CALL iom_set_domain_attr("gznl", lonvalue = zlon, & 2123 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) 2124 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 2300 ALLOCATE( zlon(Ni_0*Nj_0) ) ; zlon(:) = 0._wp 2301 ! 2302 ! CALL dom_ngb( -168.53_wp, 65.03_wp, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) 2303 CALL dom_ngb( 180.0_wp, 90.0_wp, ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 2304 CALL iom_set_domain_attr("gznl", ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig0(Nis0)-1, jbegin=mjg0(Njs0)-1, ni=Ni_0, nj=Nj_0) 2305 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0) 2306 CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp), & 2307 & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp)) 2308 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj_0) 2125 2309 ! 2126 2310 CALL iom_update_file_name('ptr') … … 2136 2320 !! 2137 2321 !!---------------------------------------------------------------------- 2138 REAL( wp), DIMENSION(1) :: zz = 1.2322 REAL(dp), DIMENSION(1) :: zz = 1. 2139 2323 !!---------------------------------------------------------------------- 2140 2324 ! … … 2198 2382 cl1 = clgrd(jg) 2199 2383 ! Equatorial section (attributs: jbegin, ni, name_suffix) 2200 CALL dom_ngb( 0. , 0., ix, iy, cl1 )2201 CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni= jpiglo, nj=1 )2384 CALL dom_ngb( 0.0_wp, 0.0_wp, ix, iy, cl1 ) 2385 CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni=Ni0glo, nj=1 ) 2202 2386 CALL iom_get_file_attr ('Eq'//cl1, name_suffix = clsuff ) 2203 2387 CALL iom_set_file_attr ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq') … … 2424 2608 ! 2425 2609 IF ( ll24 .AND. isec == 0 ) THEN ! 00:00 of the next day -> move to 24:00 of the current day 2426 CALL ju2ymds( pjday - 1. , iyear, imonth, iday, zsec )2610 CALL ju2ymds( pjday - 1.0_wp, iyear, imonth, iday, zsec ) 2427 2611 isec = 86400 2428 2612 ENDIF … … 2482 2666 CHARACTER(LEN=*), INTENT(in ) :: cdname 2483 2667 REAL(wp) , INTENT(out) :: pmiss_val 2668 REAL(dp) :: ztmp_pmiss_val 2484 2669 #if defined key_iomput 2485 2670 ! get missing value 2486 CALL xios_get_field_attr( cdname, default_value = pmiss_val ) 2671 CALL xios_get_field_attr( cdname, default_value = ztmp_pmiss_val ) 2672 pmiss_val = ztmp_pmiss_val 2487 2673 #else 2488 2674 IF( .FALSE. ) WRITE(numout,*) cdname, pmiss_val ! useless test to avoid compilation warnings
Note: See TracChangeset
for help on using the changeset viewer.
