- Timestamp:
- 2020-09-14T17:40:34+02:00 (4 years ago)
- Location:
- NEMO/branches/2019/dev_r11351_fldread_with_XIOS
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/DOM/domwri.F90 (modified) (7 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r11351_fldread_with_XIOS
- 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 9 # SETTE 10 ^/utils/CI/sette@13382 sette
-
- Property svn:externals
-
NEMO/branches/2019/dev_r11351_fldread_with_XIOS/src/OCE/DOM/domwri.F90
r10425 r13463 13 13 !!---------------------------------------------------------------------- 14 14 !! dom_wri : create and write mesh and mask file(s) 15 !! dom_uniq : identify unique point of a grid (TUVF)16 15 !! dom_stiff : diagnose maximum grid stiffness/hydrostatic consistency (s-coordinate) 17 16 !!---------------------------------------------------------------------- 17 ! 18 18 USE dom_oce ! ocean space and time domain 19 USE domutl ! 19 20 USE phycst , ONLY : rsmall 20 21 USE wet_dry, ONLY : ll_wd ! Wetting and drying … … 32 33 33 34 !! * Substitutions 34 # include " vectopt_loop_substitute.h90"35 # include "do_loop_substitute.h90" 35 36 !!---------------------------------------------------------------------- 36 37 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 73 74 ! ! ============================ 74 75 CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) 75 !76 ! ! global domain size77 CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 )78 CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 )79 CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpkglo, wp), ktype = jp_i4 )80 81 76 ! ! domain characteristics 82 77 CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 ) … … 99 94 100 95 CALL dom_uniq( zprw, 'T' ) 101 DO jj = 1, jpj 102 DO ji = 1, jpi 103 zprt(ji,jj) = ssmask(ji,jj) * zprw(ji,jj) ! ! unique point mask 104 END DO 105 END DO ! ! unique point mask 96 DO_2D( 1, 1, 1, 1 ) 97 zprt(ji,jj) = ssmask(ji,jj) * zprw(ji,jj) ! ! unique point mask 98 END_2D 106 99 CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 ) 107 100 CALL dom_uniq( zprw, 'U' ) 108 DO jj = 1, jpj 109 DO ji = 1, jpi 110 zprt(ji,jj) = ssumask(ji,jj) * zprw(ji,jj) ! ! unique point mask 111 END DO 112 END DO 101 DO_2D( 1, 1, 1, 1 ) 102 zprt(ji,jj) = ssumask(ji,jj) * zprw(ji,jj) ! ! unique point mask 103 END_2D 113 104 CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 ) 114 105 CALL dom_uniq( zprw, 'V' ) 115 DO jj = 1, jpj 116 DO ji = 1, jpi 117 zprt(ji,jj) = ssvmask(ji,jj) * zprw(ji,jj) ! ! unique point mask 118 END DO 119 END DO 106 DO_2D( 1, 1, 1, 1 ) 107 zprt(ji,jj) = ssvmask(ji,jj) * zprw(ji,jj) ! ! unique point mask 108 END_2D 120 109 CALL iom_rstput( 0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1 ) 121 110 !!gm ssfmask has been removed ==>> find another solution to defined fmaskutil … … 155 144 156 145 ! note that mbkt is set to 1 over land ==> use surface tmask 157 zprt(:,:) = ssmask(:,:) *REAL( mbkt(:,:) , wp )146 zprt(:,:) = REAL( mbkt(:,:) , wp ) 158 147 CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points 159 zprt(:,:) = ssmask(:,:) *REAL( mikt(:,:) , wp )148 zprt(:,:) = REAL( mikt(:,:) , wp ) 160 149 CALL iom_rstput( 0, 0, inum, 'misf', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points 161 zprt(:,:) = ssmask(:,:) * REAL( risfdep(:,:) , wp )162 CALL iom_rstput( 0, 0, inum, 'isfdraft', zprt, ktype = jp_r8 ) ! ! nb of ocean T-points163 150 ! ! vertical mesh 164 CALL iom_rstput( 0, 0, inum, 'e3t_0', e3t_0, ktype = jp_r8 ) ! ! scale factors 165 CALL iom_rstput( 0, 0, inum, 'e3u_0', e3u_0, ktype = jp_r8 ) 166 CALL iom_rstput( 0, 0, inum, 'e3v_0', e3v_0, ktype = jp_r8 ) 167 CALL iom_rstput( 0, 0, inum, 'e3w_0', e3w_0, ktype = jp_r8 ) 151 CALL iom_rstput( 0, 0, inum, 'e3t_1d', e3t_1d, ktype = jp_r8 ) ! ! scale factors 152 CALL iom_rstput( 0, 0, inum, 'e3w_1d', e3w_1d, ktype = jp_r8 ) 153 154 CALL iom_rstput( 0, 0, inum, 'e3t_0' , e3t_0 , ktype = jp_r8 ) 155 CALL iom_rstput( 0, 0, inum, 'e3u_0' , e3u_0 , ktype = jp_r8 ) 156 CALL iom_rstput( 0, 0, inum, 'e3v_0' , e3v_0 , ktype = jp_r8 ) 157 CALL iom_rstput( 0, 0, inum, 'e3f_0' , e3f_0 , ktype = jp_r8 ) 158 CALL iom_rstput( 0, 0, inum, 'e3w_0' , e3w_0 , ktype = jp_r8 ) 159 CALL iom_rstput( 0, 0, inum, 'e3uw_0', e3uw_0, ktype = jp_r8 ) 160 CALL iom_rstput( 0, 0, inum, 'e3vw_0', e3vw_0, ktype = jp_r8 ) 168 161 ! 169 162 CALL iom_rstput( 0, 0, inum, 'gdept_1d' , gdept_1d , ktype = jp_r8 ) ! stretched system … … 183 176 ! ! ============================ 184 177 END SUBROUTINE dom_wri 185 186 187 SUBROUTINE dom_uniq( puniq, cdgrd )188 !!----------------------------------------------------------------------189 !! *** ROUTINE dom_uniq ***190 !!191 !! ** Purpose : identify unique point of a grid (TUVF)192 !!193 !! ** Method : 1) aplly lbc_lnk on an array with different values for each element194 !! 2) check which elements have been changed195 !!----------------------------------------------------------------------196 CHARACTER(len=1) , INTENT(in ) :: cdgrd !197 REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq !198 !199 REAL(wp) :: zshift ! shift value link to the process number200 INTEGER :: ji ! dummy loop indices201 LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) :: lldbl ! store whether each point is unique or not202 REAL(wp), DIMENSION(jpi,jpj) :: ztstref203 !!----------------------------------------------------------------------204 !205 ! build an array with different values for each element206 ! in mpp: make sure that these values are different even between process207 ! -> apply a shift value according to the process number208 zshift = jpi * jpj * ( narea - 1 )209 ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) )210 !211 puniq(:,:) = ztstref(:,:) ! default definition212 CALL lbc_lnk( 'domwri', puniq, cdgrd, 1. ) ! apply boundary conditions213 lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed214 !215 puniq(:,:) = 1. ! default definition216 ! fill only the inner part of the cpu with llbl converted into real217 puniq(nldi:nlei,nldj:nlej) = REAL( COUNT( lldbl(nldi:nlei,nldj:nlej,:), dim = 3 ) , wp )218 !219 END SUBROUTINE dom_uniq220 178 221 179 … … 271 229 END DO 272 230 END DO 273 CALL lbc_lnk( 'domwri', zx1, 'T', 1. )231 CALL lbc_lnk( 'domwri', zx1, 'T', 1.0_wp ) 274 232 ! 275 233 IF( PRESENT( px1 ) ) px1 = zx1
Note: See TracChangeset
for help on using the changeset viewer.
