Changeset 4148 for branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC
- Timestamp:
- 2013-11-04T13:54:28+01:00 (11 years ago)
- Location:
- branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 10 edited
-
BDY/bdydta.F90 (modified) (3 diffs)
-
BDY/bdyice_lim2.F90 (modified) (4 diffs, 1 prop)
-
BDY/bdyini.F90 (modified) (1 diff)
-
DIA/diaptr.F90 (modified) (3 diffs)
-
DOM/domzgr.F90 (modified) (7 diffs)
-
IOM/iom.F90 (modified) (18 diffs)
-
LBC/lib_mpp.F90 (modified) (23 diffs)
-
SBC/sbc_oce.F90 (modified) (2 diffs)
-
SBC/sbccpl.F90 (modified) (2 diffs)
-
SBC/sbcmod.F90 (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90
r4147 r4148 464 464 IF( nn_dyn2d(ib_bdy) .gt. 0 .and. ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) THEN 465 465 466 IF( nn_ tra(ib_bdy) .ne. 4 ) THEN ! runoff condition : no ssh reading466 IF( nn_dyn2d(ib_bdy) .ne. jp_frs .and. nn_tra(ib_bdy) .ne. 4 ) THEN ! runoff condition : no ssh reading 467 467 jfld = jfld + 1 468 468 blf_i(jfld) = bn_ssh … … 560 560 ! Recalculate field counts 561 561 !------------------------- 562 nb_bdy_fld_sum = 0563 562 IF( ib_bdy .eq. 1 ) THEN 563 nb_bdy_fld_sum = 0 564 564 nb_bdy_fld(ib_bdy) = jfld 565 565 nb_bdy_fld_sum = jfld … … 604 604 ALLOCATE( dta_bdy(ib_bdy)%u2d(ilen0(2)) ) 605 605 ALLOCATE( dta_bdy(ib_bdy)%v2d(ilen0(3)) ) 606 IF ( nn_dyn2d_dta(ib_bdy).eq.1.or.nn_dyn2d_dta(ib_bdy).eq.3) THEN606 IF ( nn_dyn2d(ib_bdy) .ne. jp_frs .and. (nn_dyn2d_dta(ib_bdy).eq.1.or.nn_dyn2d_dta(ib_bdy).eq.3) ) THEN 607 607 jfld = jfld + 1 608 608 dta_bdy(ib_bdy)%ssh => bf(jfld)%fnow(:,1,1) -
branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim2.F90
- Property svn:keywords set to Id
r3680 r4148 32 32 !!---------------------------------------------------------------------- 33 33 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 34 !! $Id : bdyice.F90 2715 2011-03-30 15:58:35Z rblod$34 !! $Id$ 35 35 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 36 36 !!---------------------------------------------------------------------- … … 76 76 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 77 77 !! 78 INTEGER :: jb, j k, jgrd ! dummy loop indices78 INTEGER :: jb, jgrd ! dummy loop indices 79 79 INTEGER :: ii, ij ! local scalar 80 80 REAL(wp) :: zwgt, zwgt1 ! local scalar … … 86 86 ! 87 87 DO jb = 1, idx%nblen(jgrd) 88 DO jk = 1, jpkm189 88 ii = idx%nbi(jb,jgrd) 90 89 ij = idx%nbj(jb,jgrd) … … 94 93 hicif(ii,ij) = ( hicif(ii,ij) * zwgt1 + dta%hicif(jb) * zwgt ) * tmask(ii,ij,1) ! Ice depth 95 94 hsnif(ii,ij) = ( hsnif(ii,ij) * zwgt1 + dta%hsnif(jb) * zwgt ) * tmask(ii,ij,1) ! Snow depth 96 END DO97 95 END DO 98 96 CALL lbc_bdy_lnk( frld, 'T', 1., ib_bdy ) ! lateral boundary conditions -
branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90
r4147 r4148 1049 1049 1050 1050 bdytmask(:,:) = tmask(:,:,1) 1051 IF( .not. ln_mask_file ) THEN 1052 ! If .not. ln_mask_file then we need to derive mask on U and V grid 1053 ! from mask on T grid here. 1054 bdyumask(:,:) = 0.e0 1055 bdyvmask(:,:) = 0.e0 1056 DO ij=1, jpjm1 1057 DO ii=1, jpim1 1058 bdyumask(ii,ij)=bdytmask(ii,ij)*bdytmask(ii+1, ij ) 1059 bdyvmask(ii,ij)=bdytmask(ii,ij)*bdytmask(ii ,ij+1) 1060 END DO 1061 END DO 1062 CALL lbc_lnk( bdyumask(:,:), 'U', 1. ) ; CALL lbc_lnk( bdyvmask(:,:), 'V', 1. ) ! Lateral boundary cond. 1063 ENDIF 1051 1064 1052 1065 ! bdy masks and bmask are now set to zero on boundary points: -
branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r4147 r4148 350 350 DO jn = 1, nptr 351 351 tn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 352 sn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 352 353 END DO 353 354 ENDIF … … 570 571 !!-------------------------------------------------------------------- 571 572 ! 572 CALL wrk_alloc( jp i, zphi , zfoo )573 CALL wrk_alloc( jp i, jpk, z_1 )573 CALL wrk_alloc( jpj , zphi , zfoo ) 574 CALL wrk_alloc( jpj , jpk, z_1 ) 574 575 575 576 ! define time axis … … 885 886 ENDIF 886 887 ! 887 CALL wrk_dealloc( jp i, zphi , zfoo )888 CALL wrk_dealloc( jp i, jpk, z_1 )888 CALL wrk_dealloc( jpj , zphi , zfoo ) 889 CALL wrk_dealloc( jpj , jpk, z_1 ) 889 890 ! 890 891 END SUBROUTINE dia_ptr_wri -
branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r4147 r4148 176 176 !!---------------------------------------------------------------------- 177 177 !! *** ROUTINE zgr_z *** 178 !! 178 !! 179 179 !! ** Purpose : set the depth of model levels and the resulting 180 180 !! vertical scale factors. … … 645 645 END DO 646 646 END DO 647 IF( lk_mpp ) CALL mpp_sum( icompt ) 647 648 IF( icompt == 0 ) THEN 648 649 IF(lwp) WRITE(numout,*)' no isolated ocean grid points' … … 1105 1106 INTEGER :: ios ! Local integer output status for namelist read 1106 1107 REAL(wp) :: zrmax, ztaper ! temporary scalars 1107 ! 1108 REAL(wp), POINTER, DIMENSION(:,: ) :: zenv, ztmp, zmsk, zri, zrj, zhbat 1108 REAL(wp) :: zrfact ! temporary scalars 1109 REAL(wp), POINTER, DIMENSION(:,: ) :: ztmpi1, ztmpi2, ztmpj1, ztmpj2 1110 1111 ! 1112 REAL(wp), POINTER, DIMENSION(:,: ) :: zenv, zri, zrj, zhbat 1109 1113 1110 1114 NAMELIST/namzgr_sco/ln_s_sh94, ln_s_sf12, ln_sigcrit, rn_sbot_min, rn_sbot_max, rn_hc, rn_rmax,rn_theta, & … … 1114 1118 IF( nn_timing == 1 ) CALL timing_start('zgr_sco') 1115 1119 ! 1116 CALL wrk_alloc( jpi, jpj, zenv, ztmp, zmsk, zri, zrj, zhbat ) 1117 ! 1120 CALL wrk_alloc( jpi, jpj, ztmpi1, ztmpi2, ztmpj1, ztmpj2 ) 1121 CALL wrk_alloc( jpi, jpj, zenv, zri, zrj, zhbat ) 1122 ! 1118 1123 REWIND( numnam_ref ) ! Namelist namzgr_sco in reference namelist : Sigma-stretching parameters 1119 1124 READ ( numnam_ref, namzgr_sco, IOSTAT = ios, ERR = 901) … … 1168 1173 ! ! ============================= 1169 1174 ! use r-value to create hybrid coordinates 1170 DO jj = 1, jpj 1171 DO ji = 1, jpi 1172 zenv(ji,jj) = MAX( bathy(ji,jj), rn_sbot_min ) 1173 END DO 1174 END DO 1175 ! DO jj = 1, jpj 1176 ! DO ji = 1, jpi 1177 ! zenv(ji,jj) = MAX( bathy(ji,jj), 0._wp ) 1178 ! END DO 1179 ! END DO 1180 ! CALL lbc_lnk( zenv, 'T', 1._wp ) 1181 zenv(:,:) = bathy(:,:) 1175 1182 ! 1176 1183 ! Smooth the bathymetry (if required) … … 1180 1187 jl = 0 1181 1188 zrmax = 1._wp 1182 ! ! ================ ! 1183 DO WHILE( jl <= 10000 .AND. zrmax > rn_rmax ) ! Iterative loop ! 1184 ! ! ================ ! 1189 ! 1190 ! set scaling factor used in reducing vertical gradients 1191 zrfact = ( 1._wp - rn_rmax ) / ( 1._wp + rn_rmax ) 1192 ! 1193 ! initialise temporary evelope depth arrays 1194 ztmpi1(:,:) = zenv(:,:) 1195 ztmpi2(:,:) = zenv(:,:) 1196 ztmpj1(:,:) = zenv(:,:) 1197 ztmpj2(:,:) = zenv(:,:) 1198 ! 1199 ! initialise temporary r-value arrays 1200 zri(:,:) = 1._wp 1201 zrj(:,:) = 1._wp 1202 ! ! ================ ! 1203 DO WHILE( jl <= 10000 .AND. ( zrmax - rn_rmax ) > 1.e-8_wp ) ! Iterative loop ! 1204 ! ! ================ ! 1185 1205 jl = jl + 1 1186 1206 zrmax = 0._wp 1187 zmsk(:,:) = 0._wp 1207 ! we set zrmax from previous r-values (zri abd zrj) first 1208 ! if set after current r-value calculation (as previously) 1209 ! we could exit DO WHILE prematurely before checking r-value 1210 ! of current zenv 1211 DO jj = 1, nlcj 1212 DO ji = 1, nlci 1213 zrmax = MAX( zrmax, ABS(zri(ji,jj)), ABS(zrj(ji,jj)) ) 1214 END DO 1215 END DO 1216 zri(:,:) = 0._wp 1217 zrj(:,:) = 0._wp 1188 1218 DO jj = 1, nlcj 1189 1219 DO ji = 1, nlci 1190 1220 iip1 = MIN( ji+1, nlci ) ! force zri = 0 on last line (ji=ncli+1 to jpi) 1191 1221 ijp1 = MIN( jj+1, nlcj ) ! force zrj = 0 on last raw (jj=nclj+1 to jpj) 1192 zri(ji,jj) = ABS( zenv(iip1,jj ) - zenv(ji,jj) ) / ( zenv(iip1,jj ) + zenv(ji,jj) ) 1193 zrj(ji,jj) = ABS( zenv(ji ,ijp1) - zenv(ji,jj) ) / ( zenv(ji ,ijp1) + zenv(ji,jj) ) 1194 zrmax = MAX( zrmax, zri(ji,jj), zrj(ji,jj) ) 1195 IF( zri(ji,jj) > rn_rmax ) zmsk(ji ,jj ) = 1._wp 1196 IF( zri(ji,jj) > rn_rmax ) zmsk(iip1,jj ) = 1._wp 1197 IF( zrj(ji,jj) > rn_rmax ) zmsk(ji ,jj ) = 1._wp 1198 IF( zrj(ji,jj) > rn_rmax ) zmsk(ji ,ijp1) = 1._wp 1222 IF( (zenv(ji,jj) > 0._wp) .AND. (zenv(iip1,jj) > 0._wp)) THEN 1223 zri(ji,jj) = ( zenv(iip1,jj ) - zenv(ji,jj) ) / ( zenv(iip1,jj ) + zenv(ji,jj) ) 1224 END IF 1225 IF( (zenv(ji,jj) > 0._wp) .AND. (zenv(ji,ijp1) > 0._wp)) THEN 1226 zrj(ji,jj) = ( zenv(ji ,ijp1) - zenv(ji,jj) ) / ( zenv(ji ,ijp1) + zenv(ji,jj) ) 1227 END IF 1228 IF( zri(ji,jj) > rn_rmax ) ztmpi1(ji ,jj ) = zenv(iip1,jj ) * zrfact 1229 IF( zri(ji,jj) < -rn_rmax ) ztmpi2(iip1,jj ) = zenv(ji ,jj ) * zrfact 1230 IF( zrj(ji,jj) > rn_rmax ) ztmpj1(ji ,jj ) = zenv(ji ,ijp1) * zrfact 1231 IF( zrj(ji,jj) < -rn_rmax ) ztmpj2(ji ,ijp1) = zenv(ji ,jj ) * zrfact 1199 1232 END DO 1200 1233 END DO 1201 1234 IF( lk_mpp ) CALL mpp_max( zrmax ) ! max over the global domain 1202 ! lateral boundary condition on zmsk: keep 1 along closed boundary (use of MAX)1203 ztmp(:,:) = zmsk(:,:) ; CALL lbc_lnk( zmsk, 'T', 1._wp )1204 DO jj = 1, nlcj1205 DO ji = 1, nlci1206 zmsk(ji,jj) = MAX( zmsk(ji,jj), ztmp(ji,jj) )1207 END DO1208 END DO1209 1235 ! 1210 IF(lwp)WRITE(numout,*) 'zgr_sco : iter= ',jl, ' rmax= ', zrmax , ' nb of pt= ', INT( SUM(zmsk(:,:) ) )1236 IF(lwp)WRITE(numout,*) 'zgr_sco : iter= ',jl, ' rmax= ', zrmax 1211 1237 ! 1212 1238 DO jj = 1, nlcj 1213 1239 DO ji = 1, nlci 1214 iip1 = MIN( ji+1, nlci ) ! last line (ji=nlci) 1215 ijp1 = MIN( jj+1, nlcj ) ! last raw (jj=nlcj) 1216 iim1 = MAX( ji-1, 1 ) ! first line (ji=nlci) 1217 ijm1 = MAX( jj-1, 1 ) ! first raw (jj=nlcj) 1218 IF( zmsk(ji,jj) == 1._wp ) THEN 1219 ztmp(ji,jj) = ( & 1220 & zenv(iim1,ijp1)*zmsk(iim1,ijp1) + zenv(ji,ijp1)*zmsk(ji,ijp1) + zenv(iip1,ijp1)*zmsk(iip1,ijp1) & 1221 & + zenv(iim1,jj )*zmsk(iim1,jj ) + zenv(ji,jj )* 2._wp + zenv(iip1,jj )*zmsk(iip1,jj ) & 1222 & + zenv(iim1,ijm1)*zmsk(iim1,ijm1) + zenv(ji,ijm1)*zmsk(ji,ijm1) + zenv(iip1,ijm1)*zmsk(iip1,ijm1) & 1223 & ) / ( & 1224 & zmsk(iim1,ijp1) + zmsk(ji,ijp1) + zmsk(iip1,ijp1) & 1225 & + zmsk(iim1,jj ) + 2._wp + zmsk(iip1,jj ) & 1226 & + zmsk(iim1,ijm1) + zmsk(ji,ijm1) + zmsk(iip1,ijm1) & 1227 & ) 1228 ENDIF 1240 zenv(ji,jj) = MAX(zenv(ji,jj), ztmpi1(ji,jj), ztmpi2(ji,jj), ztmpj1(ji,jj), ztmpj2(ji,jj) ) 1229 1241 END DO 1230 1242 END DO 1231 1243 ! 1232 DO jj = 1, nlcj 1233 DO ji = 1, nlci 1234 IF( zmsk(ji,jj) == 1._wp ) zenv(ji,jj) = MAX( ztmp(ji,jj), bathy(ji,jj) ) 1235 END DO 1236 END DO 1237 ! 1238 ! Apply lateral boundary condition CAUTION: keep the value when the lbc field is zero 1239 ztmp(:,:) = zenv(:,:) ; CALL lbc_lnk( zenv, 'T', 1._wp ) 1240 DO jj = 1, nlcj 1241 DO ji = 1, nlci 1242 IF( zenv(ji,jj) == 0._wp ) zenv(ji,jj) = ztmp(ji,jj) 1243 END DO 1244 END DO 1244 CALL lbc_lnk( zenv, 'T', 1._wp ) 1245 1245 ! ! ================ ! 1246 1246 END DO ! End loop ! 1247 1247 ! ! ================ ! 1248 1248 ! 1249 ! Fill ghost rows with appropriate values to avoid undefined e3 values with some mpp decompositions 1250 DO ji = nlci+1, jpi 1251 zenv(ji,1:nlcj) = zenv(nlci,1:nlcj) 1252 END DO 1253 ! 1254 DO jj = nlcj+1, jpj 1255 zenv(:,jj) = zenv(:,nlcj) 1256 END DO 1249 ! DO jj = 1, jpj 1250 ! DO ji = 1, jpi 1251 ! zenv(ji,jj) = MAX( zenv(ji,jj), rn_sbot_min ) ! set all points to avoid undefined scale values 1252 ! END DO 1253 ! END DO 1257 1254 ! 1258 1255 ! Envelope bathymetry saved in hbatt 1259 1256 hbatt(:,:) = zenv(:,:) 1257 1260 1258 IF( MINVAL( gphit(:,:) ) * MAXVAL( gphit(:,:) ) <= 0._wp ) THEN 1261 1259 CALL ctl_warn( ' s-coordinates are tapered in vicinity of the Equator' ) … … 1503 1501 END DO 1504 1502 ! 1505 CALL wrk_dealloc( jpi, jpj, zenv, ztmp, zmsk, zri, zrj, zhbat ) 1506 ! 1503 CALL wrk_dealloc( jpi, jpj, zenv, ztmpi1, ztmpi2, ztmpj1, ztmpj2, zri, zrj, zhbat ) ! 1507 1504 IF( nn_timing == 1 ) CALL timing_stop('zgr_sco') 1508 1505 ! -
branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r3771 r4148 36 36 USE xios 37 37 # endif 38 USE ioipsl, ONLY : ju2ymds ! for calendar 38 39 39 40 IMPLICIT NONE … … 52 53 PRIVATE iom_p1d, iom_p2d, iom_p3d 53 54 #if defined key_iomput 54 PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_ set_grid_attr55 PRIVATE set_grid, set_scalar, set_xmlatt, set_mooring 55 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 56 PRIVATE set_grid, set_scalar, set_xmlatt, set_mooring, iom_update_file_name, iom_sdate 56 57 # endif 57 58 … … 130 131 131 132 ! end file definition 132 dtime%second=rdt133 134 135 136 133 dtime%second = rdt 134 CALL xios_set_timestep(dtime) 135 CALL xios_close_context_definition() 136 137 CALL xios_update_calendar(0) 137 138 #endif 138 139 139 140 END SUBROUTINE iom_init 140 141 … … 174 175 LOGICAL , INTENT(in ), OPTIONAL :: ldiof ! Interp On the Fly, needed for AGRIF (default = .FALSE.) 175 176 176 CHARACTER(LEN= 100) :: clname ! the name of the file based on cdname [[+clcpu]+clcpu]177 CHARACTER(LEN= 100) :: cltmpn ! tempory name to store clname (in writting mode)177 CHARACTER(LEN=256) :: clname ! the name of the file based on cdname [[+clcpu]+clcpu] 178 CHARACTER(LEN=256) :: cltmpn ! tempory name to store clname (in writting mode) 178 179 CHARACTER(LEN=10) :: clsuffix ! ".nc" or ".dimg" 179 180 CHARACTER(LEN=15) :: clcpu ! the cpu number (max jpmax_digits digits) 180 CHARACTER(LEN= 100) :: clinfo ! info character181 CHARACTER(LEN=256) :: clinfo ! info character 181 182 LOGICAL :: llok ! check the existence 182 183 LOGICAL :: llwrt ! local definition of ldwrt … … 561 562 REAL(wp) :: zscf, zofs ! sacle_factor and add_offset 562 563 INTEGER :: itmp ! temporary integer 563 CHARACTER(LEN= 100) :: clinfo ! info character564 CHARACTER(LEN= 100) :: clname ! file name564 CHARACTER(LEN=256) :: clinfo ! info character 565 CHARACTER(LEN=256) :: clname ! file name 565 566 CHARACTER(LEN=1) :: clrankpv, cldmspc ! 566 567 !--------------------------------------------------------------------- … … 1010 1011 !!---------------------------------------------------------------------- 1011 1012 1012 1013 1013 #if defined key_iomput 1014 1014 1015 SUBROUTINE iom_set_domain_attr( cd name, ni_glo, nj_glo, ibegin, jbegin, ni, nj, zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, &1015 SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, zoom_ibegin, zoom_jbegin, zoom_ni, zoom_nj, & 1016 1016 & data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask ) 1017 CHARACTER(LEN=*) , INTENT(in) :: cd name1017 CHARACTER(LEN=*) , INTENT(in) :: cdid 1018 1018 INTEGER , OPTIONAL, INTENT(in) :: ni_glo, nj_glo, ibegin, jbegin, ni, nj 1019 1019 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj … … 1022 1022 LOGICAL, DIMENSION(:,:), OPTIONAL, INTENT(in) :: mask 1023 1023 1024 IF ( xios_is_valid_domain (cd name) ) THEN1025 CALL xios_set_domain_attr ( cd name, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, &1026 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj 1027 & zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj, 1024 IF ( xios_is_valid_domain (cdid) ) THEN 1025 CALL xios_set_domain_attr ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & 1026 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & 1027 & zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj, & 1028 1028 & lonvalue=lonvalue, latvalue=latvalue,mask=mask ) 1029 1029 ENDIF 1030 1030 1031 IF ( xios_is_valid_domaingroup(cd name) ) THEN1032 CALL xios_set_domaingroup_attr( cd name, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, &1033 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj 1034 & zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj, 1031 IF ( xios_is_valid_domaingroup(cdid) ) THEN 1032 CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & 1033 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & 1034 & zoom_ibegin=zoom_ibegin, zoom_jbegin=zoom_jbegin, zoom_ni=zoom_ni, zoom_nj=zoom_nj, & 1035 1035 & lonvalue=lonvalue, latvalue=latvalue,mask=mask ) 1036 1036 ENDIF 1037 CALL xios_solve_inheritance() 1037 1038 1038 1039 END SUBROUTINE iom_set_domain_attr 1039 1040 1040 1041 1041 SUBROUTINE iom_set_axis_attr( cd name, paxis )1042 CHARACTER(LEN=*) , INTENT(in) :: cd name1042 SUBROUTINE iom_set_axis_attr( cdid, paxis ) 1043 CHARACTER(LEN=*) , INTENT(in) :: cdid 1043 1044 REAL(wp), DIMENSION(:), INTENT(in) :: paxis 1044 IF ( xios_is_valid_axis (cdname) ) CALL xios_set_axis_attr ( cdname, size=size(paxis),value=paxis ) 1045 IF ( xios_is_valid_axisgroup(cdname) ) CALL xios_set_axisgroup_attr( cdname, size=size(paxis),value=paxis ) 1045 IF ( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, size=size(paxis),value=paxis ) 1046 IF ( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, size=size(paxis),value=paxis ) 1047 CALL xios_solve_inheritance() 1046 1048 END SUBROUTINE iom_set_axis_attr 1047 1049 1048 1050 1049 SUBROUTINE iom_set_field_attr( cd name, freq_op)1050 CHARACTER(LEN=*) , INTENT(in) :: cd name1051 SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset ) 1052 CHARACTER(LEN=*) , INTENT(in) :: cdid 1051 1053 CHARACTER(LEN=*),OPTIONAL , INTENT(in) :: freq_op 1052 IF ( xios_is_valid_field (cdname) ) CALL xios_set_field_attr ( cdname, freq_op=freq_op ) 1053 IF ( xios_is_valid_fieldgroup(cdname) ) CALL xios_set_fieldgroup_attr( cdname, freq_op=freq_op ) 1054 CHARACTER(LEN=*),OPTIONAL , INTENT(in) :: freq_offset 1055 IF ( xios_is_valid_field (cdid) ) CALL xios_set_field_attr ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1056 IF ( xios_is_valid_fieldgroup(cdid) ) CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1057 CALL xios_solve_inheritance() 1054 1058 END SUBROUTINE iom_set_field_attr 1055 1059 1056 1060 1057 SUBROUTINE iom_set_file_attr( cd name, name, name_suffix )1058 CHARACTER(LEN=*) , INTENT(in) :: cd name1061 SUBROUTINE iom_set_file_attr( cdid, name, name_suffix ) 1062 CHARACTER(LEN=*) , INTENT(in) :: cdid 1059 1063 CHARACTER(LEN=*),OPTIONAL , INTENT(in) :: name, name_suffix 1060 IF ( xios_is_valid_file (cdname) ) CALL xios_set_file_attr ( cdname, name=name, name_suffix=name_suffix ) 1061 IF ( xios_is_valid_filegroup(cdname) ) CALL xios_set_filegroup_attr( cdname, name=name, name_suffix=name_suffix ) 1064 IF ( xios_is_valid_file (cdid) ) CALL xios_set_file_attr ( cdid, name=name, name_suffix=name_suffix ) 1065 IF ( xios_is_valid_filegroup(cdid) ) CALL xios_set_filegroup_attr( cdid, name=name, name_suffix=name_suffix ) 1066 CALL xios_solve_inheritance() 1062 1067 END SUBROUTINE iom_set_file_attr 1063 1068 1064 1069 1065 SUBROUTINE iom_set_grid_attr( cdname, mask ) 1066 CHARACTER(LEN=*) , INTENT(in) :: cdname 1070 SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq ) 1071 CHARACTER(LEN=*) , INTENT(in ) :: cdid 1072 CHARACTER(LEN=*),OPTIONAL , INTENT(out) :: name, name_suffix, output_freq 1073 LOGICAL :: llexist1,llexist2,llexist3 1074 !--------------------------------------------------------------------- 1075 IF( PRESENT( name ) ) name = '' ! default values 1076 IF( PRESENT( name_suffix ) ) name_suffix = '' 1077 IF( PRESENT( output_freq ) ) output_freq = '' 1078 IF ( xios_is_valid_file (cdid) ) THEN 1079 CALL xios_solve_inheritance() 1080 CALL xios_is_defined_file_attr ( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3) 1081 IF(llexist1) CALL xios_get_file_attr ( cdid, name = name ) 1082 IF(llexist2) CALL xios_get_file_attr ( cdid, name_suffix = name_suffix ) 1083 IF(llexist3) CALL xios_get_file_attr ( cdid, output_freq = output_freq ) 1084 ENDIF 1085 IF ( xios_is_valid_filegroup(cdid) ) THEN 1086 CALL xios_solve_inheritance() 1087 CALL xios_is_defined_filegroup_attr( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3) 1088 IF(llexist1) CALL xios_get_filegroup_attr( cdid, name = name ) 1089 IF(llexist2) CALL xios_get_filegroup_attr( cdid, name_suffix = name_suffix ) 1090 IF(llexist3) CALL xios_get_filegroup_attr( cdid, output_freq = output_freq ) 1091 ENDIF 1092 END SUBROUTINE iom_get_file_attr 1093 1094 1095 SUBROUTINE iom_set_grid_attr( cdid, mask ) 1096 CHARACTER(LEN=*) , INTENT(in) :: cdid 1067 1097 LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) :: mask 1068 IF ( xios_is_valid_grid (cdname) ) CALL xios_set_grid_attr ( cdname, mask=mask ) 1069 IF ( xios_is_valid_gridgroup(cdname) ) CALL xios_set_gridgroup_attr( cdname, mask=mask ) 1098 IF ( xios_is_valid_grid (cdid) ) CALL xios_set_grid_attr ( cdid, mask=mask ) 1099 IF ( xios_is_valid_gridgroup(cdid) ) CALL xios_set_gridgroup_attr( cdid, mask=mask ) 1100 CALL xios_solve_inheritance() 1070 1101 END SUBROUTINE iom_set_grid_attr 1071 1102 … … 1073 1104 SUBROUTINE set_grid( cdgrd, plon, plat ) 1074 1105 !!---------------------------------------------------------------------- 1075 !! *** ROUTINE ***1106 !! *** ROUTINE set_grid *** 1076 1107 !! 1077 1108 !! ** Purpose : define horizontal grids … … 1101 1132 END SELECT 1102 1133 ! 1103 CALL iom_set_domain_attr( "grid_"//cdgrd , mask = zmask(:,:,1) /= 0. )1104 CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = zmask(:,:,:) /= 0. )1134 CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni,nj /)) /= 0. ) 1135 CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. ) 1105 1136 ENDIF 1106 1137 … … 1110 1141 SUBROUTINE set_scalar 1111 1142 !!---------------------------------------------------------------------- 1112 !! *** ROUTINE ***1143 !! *** ROUTINE set_scalar *** 1113 1144 !! 1114 1145 !! ** Purpose : define fake grids for scalar point … … 1126 1157 SUBROUTINE set_xmlatt 1127 1158 !!---------------------------------------------------------------------- 1128 !! *** ROUTINE ***1159 !! *** ROUTINE set_xmlatt *** 1129 1160 !! 1130 1161 !! ** Purpose : automatic definitions of some of the xml attributs... 1131 1162 !! 1132 1163 !!---------------------------------------------------------------------- 1133 CHARACTER(len=6),DIMENSION( 8) :: clsuff ! suffix name1134 1164 CHARACTER(len=1),DIMENSION( 3) :: clgrd ! suffix name 1135 CHARACTER(len= 50) :: clname ! filename1165 CHARACTER(len=256) :: clsuff ! suffix name 1136 1166 CHARACTER(len=1) :: cl1 ! 1 character 1137 1167 CHARACTER(len=2) :: cl2 ! 1 character 1138 CHARACTER(len=255) :: tfo 1139 INTEGER :: idt ! time-step in seconds 1140 INTEGER :: iddss, ihhss ! number of seconds in 1 day, 1 hour and 1 year 1141 INTEGER :: iyymo ! number of months in 1 year 1142 INTEGER :: jg, jh, jd, jm, jy ! loop counters 1168 INTEGER :: ji, jg ! loop counters 1143 1169 INTEGER :: ix, iy ! i-,j- index 1144 1170 REAL(wp) ,DIMENSION(11) :: zlontao ! longitudes of tao moorings … … 1150 1176 !!---------------------------------------------------------------------- 1151 1177 ! 1152 idt = NINT( rdttra(1) )1153 iddss = NINT( rday ) ! number of seconds in 1 day1154 ihhss = NINT( rmmss * rhhmm ) ! number of seconds in 1 hour1155 iyymo = NINT( raamo ) ! number of months in 1 year1156 1157 1178 ! frequency of the call of iom_put (attribut: freq_op) 1158 tfo = TRIM(i2str(idt))//'s' 1159 CALL iom_set_field_attr('field_definition', freq_op=tfo) 1160 CALL iom_set_field_attr('SBC' , freq_op=TRIM(i2str(idt* nn_fsbc ))//'s') 1161 CALL iom_set_field_attr('ptrc_T', freq_op=TRIM(i2str(idt* nn_dttrc))//'s') 1162 CALL iom_set_field_attr('diad_T', freq_op=TRIM(i2str(idt* nn_dttrc))//'s') 1179 WRITE(cl1,'(i1)') 1 ; CALL iom_set_field_attr('field_definition', freq_op = cl1//'ts', freq_offset='0ts') 1180 WRITE(cl1,'(i1)') nn_fsbc ; CALL iom_set_field_attr('SBC' , freq_op = cl1//'ts', freq_offset='0ts') 1181 WRITE(cl1,'(i1)') nn_dttrc ; CALL iom_set_field_attr('ptrc_T' , freq_op = cl1//'ts', freq_offset='0ts') 1182 WRITE(cl1,'(i1)') nn_dttrc ; CALL iom_set_field_attr('diad_T' , freq_op = cl1//'ts', freq_offset='0ts') 1163 1183 1164 1184 ! output file names (attribut: name) 1165 clsuff(:) = (/ 'grid_T', 'grid_U', 'grid_V', 'grid_W', 'icemod', 'ptrc_T', 'diad_T', 'scalar' /) 1166 DO jg = 1, SIZE(clsuff) ! grid type 1167 DO jh = 1, 24 ! 1-24 hours 1168 WRITE(cl2,'(i2)') jh 1169 CALL dia_nam( clname, jh * ihhss, clsuff(jg), ldfsec = .TRUE. ) 1170 CALL iom_set_file_attr(TRIM(ADJUSTL(cl2))//'h_'//clsuff(jg), name=TRIM(clname)) 1171 END DO 1172 DO jd = 1, 30 ! 1-30 days 1173 WRITE(cl1,'(i1)') jd 1174 CALL dia_nam( clname, jd * iddss, clsuff(jg), ldfsec = .TRUE. ) 1175 CALL iom_set_file_attr(cl1//'d_'//clsuff(jg), name=TRIM(clname)) 1176 END DO 1177 DO jm = 1, 11 ! 1-11 months 1178 WRITE(cl1,'(i1)') jm 1179 CALL dia_nam( clname, -jm, clsuff(jg) ) 1180 CALL iom_set_file_attr(cl1//'m_'//clsuff(jg), name=TRIM(clname)) 1181 END DO 1182 DO jy = 1, 50 ! 1-50 years 1183 WRITE(cl2,'(i2)') jy 1184 CALL dia_nam( clname, -jy * iyymo, clsuff(jg) ) 1185 CALL iom_set_file_attr(TRIM(ADJUSTL(cl2))//'y_'//clsuff(jg), name=TRIM(clname)) 1186 END DO 1185 DO ji = 1, 9 1186 WRITE(cl1,'(i1)') ji 1187 CALL iom_update_file_name('file'//cl1) 1188 END DO 1189 DO ji = 1, 99 1190 WRITE(cl2,'(i2.2)') ji 1191 CALL iom_update_file_name('file'//cl2) 1187 1192 END DO 1188 1193 … … 1193 1198 ! Equatorial section (attributs: jbegin, ni, name_suffix) 1194 1199 CALL dom_ngb( 0., 0., ix, iy, cl1 ) 1195 CALL iom_set_domain_attr('Eq'//cl1, zoom_jbegin=iy, zoom_ni=jpiglo) 1196 CALL iom_set_file_attr('Eq'//cl1, name_suffix= '_Eq') 1200 CALL iom_set_domain_attr ('Eq'//cl1, zoom_jbegin=iy, zoom_ni=jpiglo) 1201 CALL iom_get_file_attr ('Eq'//cl1, name_suffix = clsuff ) 1202 CALL iom_set_file_attr ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq') 1203 CALL iom_update_file_name('Eq'//cl1) 1197 1204 END DO 1198 1205 ! TAO moorings (attributs: ibegin, jbegin, name_suffix) … … 1214 1221 SUBROUTINE set_mooring( plon, plat) 1215 1222 !!---------------------------------------------------------------------- 1216 !! *** ROUTINE ***1223 !! *** ROUTINE set_mooring *** 1217 1224 !! 1218 1225 !! ** Purpose : automatic definitions of moorings xml attributs... … … 1223 1230 !!$ CHARACTER(len=1),DIMENSION(4) :: clgrd = (/ 'T', 'U', 'V', 'W' /) ! suffix name 1224 1231 CHARACTER(len=1),DIMENSION(1) :: clgrd = (/ 'T' /) ! suffix name 1225 CHARACTER(len=50) :: clname ! file name 1232 CHARACTER(len=256) :: clname ! file name 1233 CHARACTER(len=256) :: clsuff ! suffix name 1226 1234 CHARACTER(len=1) :: cl1 ! 1 character 1227 1235 CHARACTER(len=6) :: clon,clat ! name of longitude, latitude … … 1269 1277 ENDIF 1270 1278 clname = TRIM(ADJUSTL(clat))//TRIM(ADJUSTL(clon)) 1271 CALL iom_set_domain_attr(TRIM(clname)//cl1, zoom_ibegin= ix, zoom_jbegin= iy) 1272 CALL iom_set_file_attr(TRIM(clname)//cl1, name_suffix= '_'//TRIM(clname)) 1279 CALL iom_set_domain_attr (TRIM(clname)//cl1, zoom_ibegin= ix, zoom_jbegin= iy) 1280 CALL iom_get_file_attr (TRIM(clname)//cl1, name_suffix = clsuff ) 1281 CALL iom_set_file_attr (TRIM(clname)//cl1, name_suffix = TRIM(clsuff)//'_'//TRIM(clname)) 1282 CALL iom_update_file_name(TRIM(clname)//cl1) 1273 1283 END DO 1274 1284 END DO … … 1277 1287 END SUBROUTINE set_mooring 1278 1288 1289 1290 SUBROUTINE iom_update_file_name( cdid ) 1291 !!---------------------------------------------------------------------- 1292 !! *** ROUTINE iom_update_file_name *** 1293 !! 1294 !! ** Purpose : 1295 !! 1296 !!---------------------------------------------------------------------- 1297 CHARACTER(LEN=*) , INTENT(in) :: cdid 1298 ! 1299 CHARACTER(LEN=256) :: clname 1300 CHARACTER(LEN=20) :: clfreq 1301 CHARACTER(LEN=20) :: cldate 1302 INTEGER :: idx 1303 INTEGER :: jn 1304 INTEGER :: itrlen 1305 INTEGER :: iyear, imonth, iday, isec 1306 REAL(wp) :: zsec 1307 LOGICAL :: llexist 1308 !!---------------------------------------------------------------------- 1309 1310 DO jn = 1,2 1311 1312 IF( jn == 1 ) CALL iom_get_file_attr( cdid, name = clname, output_freq = clfreq ) 1313 IF( jn == 2 ) CALL iom_get_file_attr( cdid, name_suffix = clname ) 1314 1315 IF ( TRIM(clname) /= '' ) THEN 1316 1317 idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@') 1318 DO WHILE ( idx /= 0 ) 1319 clname = clname(1:idx-1)//TRIM(cexper)//clname(idx+9:LEN_TRIM(clname)) 1320 idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@') 1321 END DO 1322 1323 idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 1324 DO WHILE ( idx /= 0 ) 1325 IF ( TRIM(clfreq) /= '' ) THEN 1326 itrlen = LEN_TRIM(clfreq) 1327 IF ( clfreq(itrlen-1:itrlen) == 'mo' ) clfreq = clfreq(1:itrlen-1) 1328 clname = clname(1:idx-1)//TRIM(clfreq)//clname(idx+6:LEN_TRIM(clname)) 1329 ELSE 1330 CALL ctl_stop('error in the name of file id '//TRIM(cdid), & 1331 & ' attribute output_freq is undefined -> cannot replace @freq@ in '//TRIM(clname) ) 1332 ENDIF 1333 idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 1334 END DO 1335 1336 idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') 1337 DO WHILE ( idx /= 0 ) 1338 cldate = iom_sdate( fjulday - rdttra(1) / rday ) 1339 clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+11:LEN_TRIM(clname)) 1340 idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') 1341 END DO 1342 1343 idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@') 1344 DO WHILE ( idx /= 0 ) 1345 cldate = iom_sdate( fjulday - rdttra(1) / rday, ldfull = .TRUE. ) 1346 clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+15:LEN_TRIM(clname)) 1347 idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@') 1348 END DO 1349 1350 idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@') 1351 DO WHILE ( idx /= 0 ) 1352 cldate = iom_sdate( fjulday + rdttra(1) / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE. ) 1353 clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+9:LEN_TRIM(clname)) 1354 idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@') 1355 END DO 1356 1357 idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@') 1358 DO WHILE ( idx /= 0 ) 1359 cldate = iom_sdate( fjulday + rdttra(1) / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE., ldfull = .TRUE. ) 1360 clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+13:LEN_TRIM(clname)) 1361 idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@') 1362 END DO 1363 1364 IF( jn == 1 ) CALL iom_set_file_attr( cdid, name = clname ) 1365 IF( jn == 2 ) CALL iom_set_file_attr( cdid, name_suffix = clname ) 1366 1367 ENDIF 1368 1369 END DO 1370 1371 END SUBROUTINE iom_update_file_name 1372 1373 1374 FUNCTION iom_sdate( pjday, ld24, ldfull ) 1375 !!---------------------------------------------------------------------- 1376 !! *** ROUTINE iom_sdate *** 1377 !! 1378 !! ** Purpose : send back the date corresponding to the given julian day 1379 !! 1380 !!---------------------------------------------------------------------- 1381 REAL(wp), INTENT(in ) :: pjday ! julian day 1382 LOGICAL , INTENT(in ), OPTIONAL :: ld24 ! true to force 24:00 instead of 00:00 1383 LOGICAL , INTENT(in ), OPTIONAL :: ldfull ! true to get the compleate date: yyyymmdd_hh:mm:ss 1384 ! 1385 CHARACTER(LEN=20) :: iom_sdate 1386 CHARACTER(LEN=50) :: clfmt ! format used to write the date 1387 INTEGER :: iyear, imonth, iday, ihour, iminute, isec 1388 REAL(wp) :: zsec 1389 LOGICAL :: ll24, llfull 1390 ! 1391 IF( PRESENT(ld24) ) THEN ; ll24 = ld24 1392 ELSE ; ll24 = .FALSE. 1393 ENDIF 1394 1395 IF( PRESENT(ldfull) ) THEN ; llfull = ldfull 1396 ELSE ; llfull = .FALSE. 1397 ENDIF 1398 1399 CALL ju2ymds( pjday, iyear, imonth, iday, zsec ) 1400 isec = NINT(zsec) 1401 1402 IF ( ll24 .AND. isec == 0 ) THEN ! 00:00 of the next day -> move to 24:00 of the current day 1403 CALL ju2ymds( pjday - 1., iyear, imonth, iday, zsec ) 1404 isec = 86400 1405 ENDIF 1406 1407 IF( iyear < 10000 ) THEN ; clfmt = "i4.4,2i2.2" ! format used to write the date 1408 ELSE ; WRITE(clfmt, "('i',i1,',2i2.2')") INT(LOG10(REAL(iyear,wp))) + 1 1409 ENDIF 1410 1411 IF( llfull ) THEN 1412 clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" 1413 ihour = isec / 3600 1414 isec = MOD(isec, 3600) 1415 iminute = isec / 60 1416 isec = MOD(isec, 60) 1417 WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday, ihour, iminute, isec ! date of the end of run 1418 ELSE 1419 WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday ! date of the end of run 1420 ENDIF 1421 1422 END FUNCTION iom_sdate 1423 1279 1424 #else 1280 1425 … … 1285 1430 1286 1431 #endif 1287 1288 FUNCTION i2str(int)1289 IMPLICIT NONE1290 INTEGER, INTENT(IN) :: int1291 CHARACTER(LEN=255) :: i2str1292 1293 WRITE(i2str,*) int1294 1295 END FUNCTION i2str1296 1432 1297 1433 !!====================================================================== -
branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r4147 r4148 163 163 164 164 ! Arrays used in mpp_lbc_north_3d() 165 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: ztab, znorthloc166 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: znorthgloio167 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: zfoldwk ! Workspace for message transfers avoiding mpi_allgather165 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: tab_3d, xnorthloc 166 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: xnorthgloio 167 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: foldwk ! Workspace for message transfers avoiding mpi_allgather 168 168 169 169 ! Arrays used in mpp_lbc_north_2d() 170 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: ztab_2d, znorthloc_2d171 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio_2d172 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: zfoldwk_2d ! Workspace for message transfers avoiding mpi_allgather170 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: tab_2d, xnorthloc_2d 171 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: xnorthgloio_2d 172 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: foldwk_2d ! Workspace for message transfers avoiding mpi_allgather 173 173 174 174 ! Arrays used in mpp_lbc_north_e() 175 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: ztab_e, znorthloc_e176 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio_e175 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: tab_e, xnorthloc_e 176 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: xnorthgloio_e 177 177 178 178 ! North fold arrays used to minimise the use of allgather operations. Set in nemo_northcomms (nemogcm) so need to be public … … 208 208 & t2p1(jpi,jprecj ,2) , t2p2(jpi,jprecj ,2) , & 209 209 ! 210 & ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk) , znorthgloio(jpi,4,jpk,jpni) , &211 & zfoldwk(jpi,4,jpk) , &212 ! 213 & ztab_2d(jpiglo,4) , znorthloc_2d(jpi,4) , znorthgloio_2d(jpi,4,jpni) , &214 & zfoldwk_2d(jpi,4) , &215 ! 216 & ztab_e(jpiglo,4+2*jpr2dj) , znorthloc_e(jpi,4+2*jpr2dj) , znorthgloio_e(jpi,4+2*jpr2dj,jpni) , &210 & tab_3d(jpiglo,4,jpk) , xnorthloc(jpi,4,jpk) , xnorthgloio(jpi,4,jpk,jpni) , & 211 & foldwk(jpi,4,jpk) , & 212 ! 213 & tab_2d(jpiglo,4) , xnorthloc_2d(jpi,4) , xnorthgloio_2d(jpi,4,jpni) , & 214 & foldwk_2d(jpi,4) , & 215 ! 216 & tab_e(jpiglo,4+2*jpr2dj) , xnorthloc_e(jpi,4+2*jpr2dj) , xnorthgloio_e(jpi,4+2*jpr2dj,jpni) , & 217 217 ! 218 218 & STAT=lib_mpp_alloc ) … … 2608 2608 ityp = -1 2609 2609 ijpjm1 = 3 2610 ztab(:,:,:) = 0.e02611 ! 2612 DO jj = nlcj - ijpj +1, nlcj ! put in znorthloc the last 4 jlines of pt3d2610 tab_3d(:,:,:) = 0.e0 2611 ! 2612 DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d 2613 2613 ij = jj - nlcj + ijpj 2614 znorthloc(:,ij,:) = pt3d(:,jj,:)2614 xnorthloc(:,ij,:) = pt3d(:,jj,:) 2615 2615 END DO 2616 2616 ! 2617 ! ! Build in procs of ncomm_north the znorthgloio2617 ! ! Build in procs of ncomm_north the xnorthgloio 2618 2618 itaille = jpi * jpk * ijpj 2619 2619 IF ( l_north_nogather ) THEN … … 2625 2625 ij = jj - nlcj + ijpj 2626 2626 DO ji = 1, nlci 2627 ztab(ji+nimpp-1,ij,:) = pt3d(ji,jj,:)2627 tab_3d(ji+nimpp-1,ij,:) = pt3d(ji,jj,:) 2628 2628 END DO 2629 2629 END DO … … 2650 2650 2651 2651 DO jr = 1,nsndto(ityp) 2652 CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) )2652 CALL mppsend(5, xnorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 2653 2653 END DO 2654 2654 DO jr = 1,nsndto(ityp) 2655 CALL mpprecv(5, zfoldwk, itaille, isendto(jr,ityp))2655 CALL mpprecv(5, foldwk, itaille, isendto(jr,ityp)) 2656 2656 iproc = isendto(jr,ityp) + 1 2657 2657 ildi = nldit (iproc) … … 2660 2660 DO jj = 1, ijpj 2661 2661 DO ji = ildi, ilei 2662 ztab(ji+iilb-1,jj,:) = zfoldwk(ji,jj,:)2662 tab_3d(ji+iilb-1,jj,:) = foldwk(ji,jj,:) 2663 2663 END DO 2664 2664 END DO … … 2675 2675 2676 2676 IF ( ityp .lt. 0 ) THEN 2677 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &2678 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )2677 CALL MPI_ALLGATHER( xnorthloc , itaille, MPI_DOUBLE_PRECISION, & 2678 & xnorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2679 2679 ! 2680 2680 DO jr = 1, ndim_rank_north ! recover the global north array … … 2685 2685 DO jj = 1, ijpj 2686 2686 DO ji = ildi, ilei 2687 ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr)2687 tab_3d(ji+iilb-1,jj,:) = xnorthgloio(ji,jj,:,jr) 2688 2688 END DO 2689 2689 END DO … … 2691 2691 ENDIF 2692 2692 ! 2693 ! The ztabarray has been either:2693 ! The tab_3d array has been either: 2694 2694 ! a. Fully populated by the mpi_allgather operation or 2695 2695 ! b. Had the active points for this domain and northern neighbours populated … … 2698 2698 ! this domain will be identical. 2699 2699 ! 2700 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition2700 CALL lbc_nfd( tab_3d, cd_type, psgn ) ! North fold boundary condition 2701 2701 ! 2702 2702 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d 2703 2703 ij = jj - nlcj + ijpj 2704 2704 DO ji= 1, nlci 2705 pt3d(ji,jj,:) = ztab(ji+nimpp-1,ij,:)2705 pt3d(ji,jj,:) = tab_3d(ji+nimpp-1,ij,:) 2706 2706 END DO 2707 2707 END DO … … 2740 2740 ityp = -1 2741 2741 ijpjm1 = 3 2742 ztab_2d(:,:) = 0.e02743 ! 2744 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc_2d the last 4 jlines of pt2d2742 tab_2d(:,:) = 0.e0 2743 ! 2744 DO jj = nlcj-ijpj+1, nlcj ! put in xnorthloc_2d the last 4 jlines of pt2d 2745 2745 ij = jj - nlcj + ijpj 2746 znorthloc_2d(:,ij) = pt2d(:,jj)2746 xnorthloc_2d(:,ij) = pt2d(:,jj) 2747 2747 END DO 2748 2748 2749 ! ! Build in procs of ncomm_north the znorthgloio_2d2749 ! ! Build in procs of ncomm_north the xnorthgloio_2d 2750 2750 itaille = jpi * ijpj 2751 2751 IF ( l_north_nogather ) THEN … … 2757 2757 ij = jj - nlcj + ijpj 2758 2758 DO ji = 1, nlci 2759 ztab_2d(ji+nimpp-1,ij) = pt2d(ji,jj)2759 tab_2d(ji+nimpp-1,ij) = pt2d(ji,jj) 2760 2760 END DO 2761 2761 END DO … … 2783 2783 2784 2784 DO jr = 1,nsndto(ityp) 2785 CALL mppsend(5, znorthloc_2d, itaille, isendto(jr,ityp), ml_req_nf(jr) )2785 CALL mppsend(5, xnorthloc_2d, itaille, isendto(jr,ityp), ml_req_nf(jr) ) 2786 2786 END DO 2787 2787 DO jr = 1,nsndto(ityp) 2788 CALL mpprecv(5, zfoldwk_2d, itaille, isendto(jr,ityp))2788 CALL mpprecv(5, foldwk_2d, itaille, isendto(jr,ityp)) 2789 2789 iproc = isendto(jr,ityp) + 1 2790 2790 ildi = nldit (iproc) … … 2793 2793 DO jj = 1, ijpj 2794 2794 DO ji = ildi, ilei 2795 ztab_2d(ji+iilb-1,jj) = zfoldwk_2d(ji,jj)2795 tab_2d(ji+iilb-1,jj) = foldwk_2d(ji,jj) 2796 2796 END DO 2797 2797 END DO … … 2808 2808 2809 2809 IF ( ityp .lt. 0 ) THEN 2810 CALL MPI_ALLGATHER( znorthloc_2d , itaille, MPI_DOUBLE_PRECISION, &2811 & znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )2810 CALL MPI_ALLGATHER( xnorthloc_2d , itaille, MPI_DOUBLE_PRECISION, & 2811 & xnorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2812 2812 ! 2813 2813 DO jr = 1, ndim_rank_north ! recover the global north array … … 2818 2818 DO jj = 1, ijpj 2819 2819 DO ji = ildi, ilei 2820 ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr)2820 tab_2d(ji+iilb-1,jj) = xnorthgloio_2d(ji,jj,jr) 2821 2821 END DO 2822 2822 END DO … … 2824 2824 ENDIF 2825 2825 ! 2826 ! The ztab array has been either:2826 ! The tab array has been either: 2827 2827 ! a. Fully populated by the mpi_allgather operation or 2828 2828 ! b. Had the active points for this domain and northern neighbours populated … … 2831 2831 ! this domain will be identical. 2832 2832 ! 2833 CALL lbc_nfd( ztab_2d, cd_type, psgn ) ! North fold boundary condition2833 CALL lbc_nfd( tab_2d, cd_type, psgn ) ! North fold boundary condition 2834 2834 ! 2835 2835 ! … … 2837 2837 ij = jj - nlcj + ijpj 2838 2838 DO ji = 1, nlci 2839 pt2d(ji,jj) = ztab_2d(ji+nimpp-1,ij)2839 pt2d(ji,jj) = tab_2d(ji+nimpp-1,ij) 2840 2840 END DO 2841 2841 END DO … … 2870 2870 ! 2871 2871 ijpj=4 2872 ztab_e(:,:) = 0.e02872 tab_e(:,:) = 0.e0 2873 2873 2874 2874 ij=0 2875 ! put in znorthloc_e the last 4 jlines of pt2d2875 ! put in xnorthloc_e the last 4 jlines of pt2d 2876 2876 DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 2877 2877 ij = ij + 1 2878 2878 DO ji = 1, jpi 2879 znorthloc_e(ji,ij)=pt2d(ji,jj)2879 xnorthloc_e(ji,ij)=pt2d(ji,jj) 2880 2880 END DO 2881 2881 END DO 2882 2882 ! 2883 2883 itaille = jpi * ( ijpj + 2 * jpr2dj ) 2884 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &2885 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )2884 CALL MPI_ALLGATHER( xnorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 2885 & xnorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2886 2886 ! 2887 2887 DO jr = 1, ndim_rank_north ! recover the global north array … … 2892 2892 DO jj = 1, ijpj+2*jpr2dj 2893 2893 DO ji = ildi, ilei 2894 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)2894 tab_e(ji+iilb-1,jj) = xnorthgloio_e(ji,jj,jr) 2895 2895 END DO 2896 2896 END DO … … 2900 2900 ! 2. North-Fold boundary conditions 2901 2901 ! ---------------------------------- 2902 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )2902 CALL lbc_nfd( tab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 2903 2903 2904 2904 ij = jpr2dj … … 2907 2907 ij = ij +1 2908 2908 DO ji= 1, nlci 2909 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)2909 pt2d(ji,jj) = tab_e(ji+nimpp-1,ij) 2910 2910 END DO 2911 2911 END DO -
branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90
r4147 r4148 71 71 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx , sfx_b !: salt flux [PSU/m2/s] 72 72 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_tot !: total E-P over ocean and ice [Kg/m2/s] 73 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fmmflx !: freshwater budget: freezing/melting [Kg/m2/s] 73 74 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnf , rnf_b !: river runoff [Kg/m2/s] 74 75 !! … … 116 117 & qsr_tot(jpi,jpj) , qsr (jpi,jpj) , & 117 118 & emp (jpi,jpj) , emp_b(jpi,jpj) , & 118 & sfx (jpi,jpj) , sfx_b(jpi,jpj) , emp_tot(jpi,jpj) 119 & sfx (jpi,jpj) , sfx_b(jpi,jpj) , emp_tot(jpi,jpj), fmmflx(jpi,jpj), STAT=ierr(2) ) 119 120 ! 120 121 ALLOCATE( rnf (jpi,jpj) , sbc_tsc (jpi,jpj,jpts) , qsr_hc (jpi,jpj,jpk) , & -
branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90
r4147 r4148 373 373 ! 374 374 IF( TRIM( sn_rcv_tau%cldes ) /= 'oce and ice' ) THEN ! 'oce and ice' case ocean stress on ocean mesh used 375 srcv(jpr_it x1:jpr_itz2)%laction = .FALSE. ! ice components not received375 srcv(jpr_itz1:jpr_itz2)%laction = .FALSE. ! ice components not received (itx1 and ity1 used later) 376 376 srcv(jpr_itx1)%clgrid = 'U' ! ocean stress used after its transformation 377 377 srcv(jpr_ity1)%clgrid = 'V' ! i.e. it is always at U- & V-points for i- & j-comp. resp. … … 896 896 !! third as 2 components on the cp_ice_msh point 897 897 !! 898 !! In 'oce and ice' case, only one vector stress field898 !! Except in 'oce and ice' case, only one vector stress field 899 899 !! is received. It has already been processed in sbc_cpl_rcv 900 900 !! so that it is now defined as (i,j) components given at U- 901 !! and V-points, respectively. Therefore, hereonly the third901 !! and V-points, respectively. Therefore, only the third 902 902 !! transformation is done and only if the ice-grid is a 'I'-grid. 903 903 !! -
branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r4147 r4148 153 153 sfx(:,:) = 0.0_wp ! the salt flux due to freezing/melting will be computed (i.e. will be non-zero) 154 154 ! only if sea-ice is present 155 156 fmmflx(:,:) = 0.0_wp ! freezing-melting array initialisation 155 157 156 158 ! ! restartability … … 371 373 ! (includes virtual salt flux beneath ice 372 374 ! in linear free surface case) 375 CALL iom_put( "fmmflx", fmmflx ) ! Freezing-melting water flux 373 376 CALL iom_put( "qt" , qns + qsr ) ! total heat flux 374 377 CALL iom_put( "qns" , qns ) ! solar heat flux
Note: See TracChangeset
for help on using the changeset viewer.
