Changeset 14623
- Timestamp:
- 2021-03-21T19:40:22+01:00 (3 years ago)
- Location:
- utils/tools/DOMAINcfg/src
- Files:
-
- 9 added
- 40 edited
-
agrif_connect.F90 (modified) (3 diffs)
-
agrif_dom_update.F90 (modified) (3 diffs)
-
agrif_user.F90 (modified) (12 diffs)
-
calendar.f90 (modified) (2 diffs)
-
do_loop_substitute.h90 (added)
-
dom_oce.F90 (modified) (2 diffs)
-
domain.F90 (modified) (5 diffs)
-
dombat.F90 (modified) (2 diffs)
-
domcfg.f90 (modified) (1 diff)
-
domclo.F90 (modified) (1 diff)
-
domhgr.F90 (modified) (4 diffs)
-
domisf.F90 (modified) (5 diffs)
-
dommsk.F90 (modified) (6 diffs)
-
domngb.F90 (modified) (2 diffs)
-
domwri.F90 (modified) (1 diff)
-
domzgr.F90 (modified) (15 diffs)
-
errioipsl.f90 (modified) (2 diffs)
-
flincom.f90 (added)
-
fliocom.f90 (added)
-
getincom.f90 (added)
-
halo_mng.F90 (added)
-
histcom.f90 (added)
-
in_out_manager.F90 (modified) (7 diffs)
-
ioipsl.f90 (modified) (2 diffs)
-
iom.F90 (modified) (75 diffs)
-
iom_def.F90 (modified) (5 diffs)
-
iom_nf90.F90 (modified) (25 diffs)
-
lbc_lnk_multi_generic.h90 (modified) (3 diffs)
-
lbc_nfd_ext_generic.h90 (modified) (3 diffs)
-
lbc_nfd_generic.h90 (modified) (7 diffs)
-
lbc_nfd_nogather_generic.h90 (modified) (15 diffs)
-
lbclnk.F90 (modified) (4 diffs)
-
lbcnfd.F90 (modified) (8 diffs)
-
lib_fortran.F90 (modified) (8 diffs)
-
lib_fortran_generic.h90 (modified) (5 diffs)
-
lib_mpp.F90 (modified) (54 diffs)
-
mpp_allreduce_generic.h90 (modified) (4 diffs)
-
mpp_lbc_north_icb_generic.h90 (added)
-
mpp_lnk_generic.h90 (modified) (6 diffs)
-
mpp_lnk_icb_generic.h90 (added)
-
mpp_loc_generic.h90 (modified) (5 diffs)
-
mpp_nfd_generic.h90 (modified) (7 diffs)
-
mppini.F90 (modified) (52 diffs)
-
nc4interface.f90 (modified) (2 diffs)
-
nemogcm.F90 (modified) (9 diffs)
-
par_kind.f90 (modified) (2 diffs)
-
par_oce.f90 (modified) (3 diffs)
-
restcom.f90 (added)
-
stringop.f90 (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
utils/tools/DOMAINcfg/src/agrif_connect.F90
r13204 r14623 74 74 ELSEWHERE 75 75 ssmask(i1:i2,j1:j2) = 1. 76 END WHERE 76 END WHERE 77 77 ENDIF 78 78 ! … … 146 146 IF( e3t_interp(ji,jj,jk) == -10 ) THEN ! the connection has not yet been done 147 147 e3t_interp(ji,jj,jk) = MAX( ptab(ji,jj,jk),MIN(e3zps_min, e3t_1d(jk)*e3zps_rat) ) 148 e3t_interp(ji,jj,jk) = MIN( e3t_interp(ji,jj,jk),e3t_1d(jk) )148 ! e3t_interp(ji,jj,jk) = MIN( e3t_interp(ji,jj,jk),e3t_1d(jk) ) 149 149 e3t_0(ji,jj,jk) = ( 1. - ztabramp(ji,jj) )*e3t_0(ji,jj,jk) + ztabramp(ji,jj)*e3t_interp(ji,jj,jk) 150 150 ENDIF … … 180 180 ! --- West --- ! 181 181 IF( ((nbondi == -1) .OR. (nbondi == 2) ).AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6)) THEN 182 ind1 = 1+nbghostcells + istart182 ind1 = nn_hls + 1 + nbghostcells + istart 183 183 ind2 = ind1 + ispongearea 184 DO jj = 1, jpj 185 DO ji = ind1, ind2 186 ztabramp(ji,jj) = REAL( ind2 - ji ) * z1_spongearea * umask(ind1,jj,1) 187 END DO 188 ENDDO 184 DO ji = mi0(ind1), mi1(ind2) 185 DO jj = 1, jpj 186 ztabramp(ji,jj) = REAL(ind2 - mig(ji), wp) * z1_spongearea * umask(ind1,jj,1) 187 END DO 188 ENDDO 189 ! ghost cells: 190 ind1 = 1 191 ind2 = nn_hls + 1 + nbghostcells + istart ! halo + land + nbghostcells 192 DO ji = mi0(ind1), mi1(ind2) 193 DO jj = 1, jpj 194 ztabramp(ji,jj) = 1._wp 195 END DO 196 END DO 189 197 ENDIF 190 198 191 199 ! --- East --- ! 192 200 IF( ((nbondi == 1) .OR. (nbondi == 2) ).AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6)) THEN 193 ind2 = nlci - nbghostcells- istart201 ind2 = jpiglo - (nn_hls + nbghostcells ) - istart 194 202 ind1 = ind2 -ispongearea 195 DO j j = 1, jpj196 DO j i = ind1, ind2197 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ji- ind1 ) * z1_spongearea * umask(ind2-1,jj,1) )203 DO ji = mi0(ind1), mi1(ind2) 204 DO jj = 1, jpj 205 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mig(ji) - ind1 ) * z1_spongearea * umask(ind2-1,jj,1) ) 198 206 ENDDO 199 207 ENDDO 208 ! ghost cells: 209 ind1 = jpiglo - (nn_hls + nbghostcells ) - istart ! halo + land + nbghostcells - 1 210 ind2 = jpiglo - 1 211 DO ji = mi0(ind1), mi1(ind2) 212 DO jj = 1, jpj 213 ztabramp(ji,jj) = 1._wp 214 END DO 215 END DO 200 216 ENDIF 201 217 202 218 ! --- South --- ! 203 219 IF(( (nbondj == -1) .OR. (nbondj == 2) ).AND.(lk_south)) THEN 204 ind1 = 1+nbghostcells + istart220 ind1 = nn_hls + 1 + nbghostcells + istart 205 221 ind2 = ind1 + ispongearea 206 DO jj = ind1, ind2222 DO jj = mj0(ind1), mj1(ind2) 207 223 DO ji = 1, jpi 208 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - jj ) * z1_spongearea * vmask(ji,ind1,1) ) 209 END DO 210 ENDDO 224 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - mjg(jj) ) * z1_spongearea * vmask(ji,ind1,1) ) 225 END DO 226 ENDDO 227 ! ghost cells: 228 ind1 = 1 229 ind2 = nn_hls + 1 + nbghostcells + istart ! halo + land + nbghostcells 230 DO jj = mj0(ind1), mj1(ind2) 231 DO ji = 1, jpi 232 ztabramp(ji,jj) = 1._wp 233 END DO 234 END DO 211 235 ENDIF 212 236 213 237 ! --- North --- ! 214 238 IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 215 ind2 = nlcj - nbghostcells- istart216 ind1 = ind2 -ispongearea 217 DO jj = ind1, ind2239 ind2 = jpjglo - (nn_hls + nbghostcells) - istart 240 ind1 = ind2 -ispongearea 241 DO jj = mj0(ind1), mj1(ind2) 218 242 DO ji = 1, jpi 219 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( jj - ind1 ) * z1_spongearea * vmask(ji,ind2-1,1) ) 220 END DO 221 ENDDO 243 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mjg(jj) - ind1 ) * z1_spongearea * vmask(ji,ind2-1,1) ) 244 END DO 245 ENDDO 246 ! ghost cells: 247 ind1 = jpjglo - (nn_hls + nbghostcells) - istart ! halo + land + nbghostcells - 1 248 ind2 = jpjglo 249 DO jj = mj0(ind1), mj1(ind2) 250 DO ji = 1, jpi 251 ztabramp(ji,jj) = 1._wp 252 END DO 253 END DO 222 254 ENDIF 223 255 ! -
utils/tools/DOMAINcfg/src/agrif_dom_update.F90
r13204 r14623 76 76 DO jj=j1,j2 77 77 DO ji=i1,i2 78 IF ( mbkt(ji,jj) .GE. jk) THEN78 IF ((ssmask(ji,jj) /=0.).AND.( mbkt(ji,jj) .GE. jk )) THEN 79 79 tabres(ji,jj,jk) = e3t_0(ji,jj,jk) 80 80 ELSE … … 90 90 IF( mbkt(ji,jj) .GE. jk ) THEN 91 91 e3t_0(ji,jj,jk) = MAX(tabres(ji,jj,jk),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat)) 92 ! e3t_0(ji,jj,jk) = tabres(ji,jj,jk) 92 93 ELSE 93 94 e3t_0(ji,jj,jk) = e3t_1d(jk) … … 97 98 END DO 98 99 99 CALL lbc_lnk('update_e3t',e3t_0,'T',1. )100 CALL lbc_lnk('update_e3t',e3t_0,'T',1.,kfillmode = jpfillcopy) 100 101 ! 101 102 ENDIF -
utils/tools/DOMAINcfg/src/agrif_user.F90
r14606 r14623 45 45 IMPLICIT NONE 46 46 ! 47 INTEGER :: nx, ny48 47 INTEGER :: irafx, irafy 49 48 LOGICAL :: ln_perio … … 52 51 irafy = agrif_irhoy() 53 52 54 nx = nlci ; ny = nlcj55 53 56 54 ! IF(jperio /=1 .AND. jperio/=4 .AND. jperio/=6 ) THEN … … 71 69 72 70 WRITE(*,*) ' ' 73 WRITE(*,*)'Size of the High resolution grid: ', nx,' x ',ny71 WRITE(*,*)'Size of the High resolution grid: ',jpi,' x ',jpj 74 72 WRITE(*,*) ' ' 75 73 … … 202 200 203 201 INTEGER :: ind1, ind2, ind3 204 INTEGER :: nx, ny205 202 INTEGER ::nbghostcellsfine_tot_x, nbghostcellsfine_tot_y 206 203 INTEGER :: irafx … … 211 208 !--------------------------------------------------------------------- 212 209 213 nx=nlci ; ny=nlcj 214 215 ind2 = 2 + nbghostcells_x 216 ind3 = 2 + nbghostcells_y_s 210 ind2 = nn_hls + 2 + nbghostcells_x 211 ind3 = nn_hls + 2 + nbghostcells_y_s 212 217 213 nbghostcellsfine_tot_x=nbghostcells_x+1 218 214 nbghostcellsfine_tot_y=max(nbghostcells_y_s,nbghostcells_y_n)+1 … … 230 226 endif 231 227 232 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/ nx,ny/),glamt_id)233 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/ nx,ny/),glamu_id)234 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/ nx,ny/),glamv_id)235 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/ nx,ny/),glamf_id)236 237 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/ nx,ny/),gphit_id)238 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/ nx,ny/),gphiu_id)239 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/ nx,ny/),gphiv_id)240 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/ nx,ny/),gphif_id)228 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),glamt_id) 229 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),glamu_id) 230 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),glamv_id) 231 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),glamf_id) 232 233 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gphit_id) 234 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gphiu_id) 235 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gphiv_id) 236 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gphif_id) 241 237 242 238 ! Horizontal scale factors 243 239 244 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/ nx,ny/),e1t_id)245 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/ nx,ny/),e1u_id)246 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/ nx,ny/),e1v_id)247 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/ nx,ny/),e1f_id)248 249 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/ nx,ny/),e2t_id)250 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/ nx,ny/),e2u_id)251 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/ nx,ny/),e2v_id)252 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/ nx,ny/),e2f_id)240 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1t_id) 241 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 242 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1v_id) 243 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1f_id) 244 245 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2t_id) 246 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2u_id) 247 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2v_id) 248 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2f_id) 253 249 254 250 ! Bathymetry 255 251 256 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/ nx,ny/),bathy_id)252 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),bathy_id) 257 253 258 254 ! Vertical scale factors 259 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/ nx,ny,jpk/),e3t_id)260 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/ nx,ny,jpk/),e3t_copy_id)261 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/ nx,ny,jpk+1/),e3t_connect_id)262 263 CALL agrif_declare_variable((/1,2,0/),(/ind2-1,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/ nx,ny,jpk/),e3u_id)264 CALL agrif_declare_variable((/2,1,0/),(/ind2,ind3-1,0/),(/'x','y','N'/),(/1,1,1/),(/ nx,ny,jpk/),e3v_id)255 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),e3t_id) 256 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),e3t_copy_id) 257 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk+1/),e3t_connect_id) 258 259 CALL agrif_declare_variable((/1,2,0/),(/ind2-1,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),e3u_id) 260 CALL agrif_declare_variable((/2,1,0/),(/ind2,ind3-1,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),e3v_id) 265 261 266 262 ! Bottom level 267 263 268 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/ nx,ny/),bottom_level_id)264 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),bottom_level_id) 269 265 270 266 CALL Agrif_Set_bcinterp(glamt_id,interp=AGRIF_linear) … … 348 344 CALL Agrif_Set_bc( e3t_copy_id, (/-npt_copy*irafx,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/)) 349 345 350 CALL Agrif_Set_bcinterp(e3t_connect_id,interp=AGRIF_ ppm)351 CALL Agrif_Set_interp(e3t_connect_id,interp=AGRIF_ ppm)346 CALL Agrif_Set_bcinterp(e3t_connect_id,interp=AGRIF_linear) 347 CALL Agrif_Set_interp(e3t_connect_id,interp=AGRIF_linear) 352 348 CALL Agrif_Set_bc( e3t_connect_id, (/-(npt_copy+npt_connect)*irafx-1,-npt_copy*irafx/)) 353 349 … … 589 585 EXTERNAL :: init_glamt, init_glamu, init_glamv, init_glamf 590 586 EXTERNAL :: init_gphit, init_gphiu, init_gphiv, init_gphif 591 REAL, EXTERNAL :: longitude_linear_interp 592 593 INTEGER :: ji,jj,i1,i2,j1,j2 594 REAL, DIMENSION(jpi,jpj) :: tab2dtemp 595 INTEGER :: ind2,ind3 596 INTEGER :: irhox, irhoy 597 598 irhox = agrif_irhox() 599 irhoy = agrif_irhoy() 587 EXTERNAL :: longitude_linear_interp 588 600 589 CALL Agrif_Set_external_linear_interp(longitude_linear_interp) 601 590 … … 637 626 USE lbclnk 638 627 LOGICAL :: ln_perio 639 INTEGER nx,ny628 INTEGER jpi,jpj 640 629 641 630 EXTERNAL :: init_e1t, init_e1u, init_e1v, init_e1f 642 631 EXTERNAL :: init_e2t, init_e2u, init_e2v, init_e2f 643 644 nx = nlci ; ny = nlcj645 632 646 633 ln_perio=.FALSE. … … 1078 1065 & npt_copy 1079 1066 1080 REWIND( numnam_ref ) ! Namelist namagrif in reference namelist : nesting parameters1067 ! REWIND( numnam_ref ) ! Namelist namagrif in reference namelist : nesting parameters 1081 1068 READ ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901 ) 1082 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist' , lwp)1083 1084 REWIND( numnam_cfg ) ! Namelist namzgr in configuration namelist : nesting parameters1069 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist') 1070 1071 ! REWIND( numnam_cfg ) ! Namelist namzgr in configuration namelist : nesting parameters 1085 1072 READ ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 1086 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist' , lwp)1073 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist') 1087 1074 IF(lwm) WRITE ( numond, namagrif ) 1088 1075 … … 1102 1089 nbghostcells_y_n = nbghostcells 1103 1090 1091 IF ((jperio == 1).OR.(jperio == 4)) THEN 1092 nbghostcells_x = 0 1093 ENDIF 1094 IF (jperio == 4) THEN 1095 nbghostcells_y_s = 0 1096 ENDIF 1097 1098 IF (.not.agrif_root()) THEN 1104 1099 lk_west = .NOT. ( Agrif_Ix() == 1 ) 1105 1100 lk_east = .NOT. ( Agrif_Ix() + nbcellsx/AGRIF_Irhox() == Agrif_Parent(jpiglo) -1 ) 1106 1101 lk_south = .NOT. ( Agrif_Iy() == 1 ) 1107 1102 lk_north = .NOT. ( Agrif_Iy() + nbcellsy/AGRIF_Irhoy() == Agrif_Parent(jpjglo) -1 ) 1108 1109 IF (.not.agrif_root()) THEN1110 IF (jperio == 1) THEN1111 nbghostcells_x = 01112 ENDIF1113 1103 IF (.NOT.lk_south) THEN 1114 1104 nbghostcells_y_s = 0 … … 1146 1136 ! 1147 1137 SELECT CASE( i ) 1148 CASE(1) ; indglob = indloc + nimppt(nprocloc+1) - 11149 CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 11138 CASE(1) ; indglob = mig(indloc) 1139 CASE(2) ; indglob = mjg(indloc) 1150 1140 CASE DEFAULT 1151 1141 indglob = indloc -
utils/tools/DOMAINcfg/src/calendar.f90
r6951 r14623 1 1 MODULE calendar 2 !$AGRIF_DO_NOT_TREAT 2 3 !- 3 4 !$Id: calendar.f90 2459 2010-12-07 11:17:48Z smasson $ … … 1042 1043 !=== 1043 1044 !- 1045 !$AGRIF_END_DO_NOT_TREAT 1044 1046 END MODULE calendar -
utils/tools/DOMAINcfg/src/dom_oce.F90
r13390 r14623 151 151 INTEGER , PUBLIC :: nbondi, nbondj !: mark of i- and j-direction local boundaries 152 152 153 ! !: domain MPP decomposition parameters 154 INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom 155 INTEGER , PUBLIC :: nproc !: number for local processor 156 INTEGER , PUBLIC :: narea !: number for local area 157 INTEGER , PUBLIC :: nbondi, nbondj !: mark of i- and j-direction local boundaries 158 INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy(:) !: mark i-direction local boundaries for BDY open boundaries 159 INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy(:) !: mark j-direction local boundaries for BDY open boundaries 160 INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy_b(:) !: mark i-direction of neighbours local boundaries for BDY open boundaries 161 INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy_b(:) !: mark j-direction of neighbours local boundaries for BDY open boundaries 162 153 163 INTEGER, PUBLIC :: npolj !: north fold mark (0, 3 or 4) 154 INTEGER, PUBLIC :: nlci, nldi, nlei !: i-dimensions of the local subdomain and its first and last indoor indices155 INTEGER, PUBLIC :: nlcj, nldj, nlej !: i-dimensions of the local subdomain and its first and last indoor indices156 164 INTEGER, PUBLIC :: noea, nowe !: index of the local neighboring processors in 157 165 INTEGER, PUBLIC :: noso, nono !: east, west, south and north directions 158 166 INTEGER, PUBLIC :: nidom !: ??? 159 167 160 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain i-index 161 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg !: local ==> global domain j-index 162 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global ==> local domain i-index (mi0=1 and mi1=0 if the global index 163 ! ! is not in the local domain) 164 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global ==> local domain j-index (mj0=1 and mj1=0 if the global index 165 ! ! is not in the local domain) 166 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt, njmppt !: i-, j-indexes for each processor 167 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt !: i-, j- processor neighbour existence 168 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nlcit , nlcjt !: dimensions of every subdomain 169 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nldit , nldjt !: first, last indoor index for each i-domain 170 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nleit , nlejt !: first, last indoor index for each j-domain 171 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nfiimpp, nfipproc, nfilcit 168 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain, including halos (jpiglo), i-index 169 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg !: local ==> global domain, including halos (jpjglo), j-index 170 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig0 !: local ==> global domain, excluding halos (Ni0glo), i-index 171 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg0 !: local ==> global domain, excluding halos (Nj0glo), j-index 172 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig0_oldcmp !: local ==> global domain, excluding halos (Ni0glo), i-index 173 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg0_oldcmp !: local ==> global domain, excluding halos (Nj0glo), j-index 174 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global, including halos (jpiglo) ==> local domain i-index 175 ! !: (mi0=1 and mi1=0 if global index not in local domain) 176 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global, including halos (jpjglo) ==> local domain j-index 177 ! !: (mj0=1 and mj1=0 if global index not in local domain) 178 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt, njmppt !: i-, j-indexes for each processor 179 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt !: i-, j- processor neighbour existence 180 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: jpiall, jpjall !: dimensions of all subdomain 181 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nis0all, njs0all !: first, last indoor index for all i-subdomain 182 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nie0all, nje0all !: first, last indoor index for all j-subdomain 183 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nfimpp, nfproc, nfjpi 184 172 185 173 186 !!---------------------------------------------------------------------- … … 312 325 ierr(:) = 0 313 326 ! 314 ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(1) ) 327 ALLOCATE( mig(jpi), mjg(jpj), mig0(jpi), mjg0(jpj), mig0_oldcmp(jpi), mjg0_oldcmp(jpj),& 328 STAT=ierr(1) ) 315 329 ! 316 330 ALLOCATE( mi0(jpiglo) , mi1 (jpiglo), mj0(jpjglo) , mj1 (jpjglo) , & -
utils/tools/DOMAINcfg/src/domain.F90
r14199 r14623 76 76 ! !== Reference coordinate system ==! 77 77 ! 78 CALL dom_glo ! global domain versus local domain 78 79 CALL dom_nam ! read namelist ( namrun, namdom ) 80 ! CALL dom_clo ! Closed seas and lake 79 81 80 82 CALL dom_hgr ! Horizontal mesh 81 83 CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry 82 84 CALL dom_msk( ik_top, ik_bot ) ! Masks 83 IF ( ln_domclo ) CALL dom_clo ! Closed seas and lake85 ! 84 86 ! 85 87 CALL dom_ctl ! print extrema of masked scale factors … … 91 93 END SUBROUTINE dom_init 92 94 95 SUBROUTINE dom_glo 96 !!---------------------------------------------------------------------- 97 !! *** ROUTINE dom_glo *** 98 !! 99 !! ** Purpose : initialization of global domain <--> local domain indices 100 !! 101 !! ** Method : 102 !! 103 !! ** Action : - mig , mjg : local domain indices ==> global domain, including halos, indices 104 !! - mig0, mjg0: local domain indices ==> global domain, excluding halos, indices 105 !! - mi0 , mi1 : global domain indices ==> local domain indices 106 !! - mj0 , mj1 (if global point not in the local domain ==> mi0>mi1 and/or mj0>mj1) 107 !!---------------------------------------------------------------------- 108 INTEGER :: ji, jj ! dummy loop argument 109 !!---------------------------------------------------------------------- 110 ! 111 DO ji = 1, jpi ! local domain indices ==> global domain, including halos, indices 112 mig(ji) = ji + nimpp - 1 113 END DO 114 DO jj = 1, jpj 115 mjg(jj) = jj + njmpp - 1 116 END DO 117 ! ! local domain indices ==> global domain, excluding halos, indices 118 ! 119 mig0(:) = mig(:) - nn_hls 120 mjg0(:) = mjg(:) - nn_hls 121 ! WARNING: to keep compatibility with the trunk that was including periodocity into the input data, 122 ! we must define mig0 and mjg0 as bellow. 123 ! Once we decide to forget trunk compatibility, we must simply define mig0 and mjg0 as: 124 mig0_oldcmp(:) = mig0(:) + COUNT( (/ jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 /) ) 125 mjg0_oldcmp(:) = mjg0(:) + COUNT( (/ jperio == 2 .OR. jperio == 7 /) ) 126 ! 127 ! ! global domain, including halos, indices ==> local domain indices 128 ! ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the 129 ! ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. 130 DO ji = 1, jpiglo 131 mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) ) 132 mi1(ji) = MAX( 0 , MIN( ji - nimpp + 1, jpi ) ) 133 END DO 134 DO jj = 1, jpjglo 135 mj0(jj) = MAX( 1 , MIN( jj - njmpp + 1, jpj+1 ) ) 136 mj1(jj) = MAX( 0 , MIN( jj - njmpp + 1, jpj ) ) 137 END DO 138 IF(lwp) THEN ! control print 139 WRITE(numout,*) 140 WRITE(numout,*) 'dom_glo : domain: global <<==>> local ' 141 WRITE(numout,*) '~~~~~~~ ' 142 WRITE(numout,*) ' global domain: jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpkglo = ', jpkglo 143 WRITE(numout,*) ' local domain: jpi = ', jpi , ' jpj = ', jpj , ' jpk = ', jpk 144 WRITE(numout,*) 145 ENDIF 146 ! 147 END SUBROUTINE dom_glo 148 93 149 SUBROUTINE dom_nam 94 150 !!---------------------------------------------------------------------- … … 108 164 109 165 NAMELIST/namdom/ ln_read_cfg, nn_bathy, cn_domcfg, cn_topo, cn_bath, cn_lon, cn_lat, rn_scale, nn_interp, & 110 & cn_topolvl, cn_fisfd, cn_visfd, cn_bathlvl, cn_fcoord, &166 & cn_topolvl, cn_fisfd, cn_visfd, cn_bathlvl, cn_fcoord, & 111 167 & rn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh, rn_hmin, & 112 168 & rn_atfp , rn_rdt , ln_crs , jphgr_msh , & … … 116 172 117 173 INTEGER :: ios ! Local integer output status for namelist read 118 !!---------------------------------------------------------------------- 119 120 REWIND( numnam_ref ) ! Namelist namrun in reference namelist : Parameters of the run 174 CHARACTER(256) :: c_iomsg 175 !!---------------------------------------------------------------------- 176 177 121 178 READ ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) 122 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist' , lwp)123 124 RE WIND( numnam_cfg ) ! Namelist namrun in configuration namelist : Parameters of the run125 READ ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 ) 126 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist' , lwp)179 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist') 180 181 READ ( numnam_cfg, namrun, IOSTAT = ios, IOMSG = c_iomsg, ERR = 902 ) 182 183 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist') 127 184 IF(lwm) WRITE ( numond, namrun ) 128 185 ! … … 152 209 rn_scale = 1. 153 210 154 REWIND( numnam_ref ) ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep)211 !REWIND( numnam_ref ) ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep) 155 212 READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 156 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' , lwp)213 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' ) 157 214 158 215 ! 159 REWIND( numnam_cfg ) ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep)216 !REWIND( numnam_cfg ) ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep) 160 217 READ ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) 161 904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' , lwp)218 904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' ) 162 219 IF(lwm) WRITE ( numond, namdom ) 163 220 ! -
utils/tools/DOMAINcfg/src/dombat.F90
r13204 r14623 49 49 latname=TRIM(cn_lat) 50 50 51 CALL iom_open( bathyfile, inum, l agrif=.FALSE. )51 CALL iom_open( bathyfile, inum, ldiof=.TRUE. ) 52 52 53 53 ! check if lon/lat are 2D arrays … … 404 404 ! 405 405 ENDIF 406 CALL lbc_lnk( 'dom_bat', bathy, 'T', 1. 406 CALL lbc_lnk( 'dom_bat', bathy, 'T', 1.,kfillmode = jpfillcopy) 407 407 408 408 ! Correct South and North 409 #if defined key_agrif410 IF( lk_south ) THEN411 IF( (nbondj == -1).OR.(nbondj == 2) ) THEN412 bathy(:,1)=bathy(:,2)413 ENDIF414 ELSE415 bathy(:,1) = 0.416 ENDIF417 #else418 IF ((nbondj == -1).OR.(nbondj == 2)) THEN419 bathy(:,1)=bathy(:,2)420 ENDIF421 #endif422 423 IF ((nbondj == 1).OR.(nbondj == 2)) THEN424 bathy(:,jpj)=bathy(:,jpj-1)425 ENDIF426 427 ! Correct West and East428 IF (jperio /=1) THEN429 IF ((nbondi == -1).OR.(nbondi == 2)) THEN430 bathy(1,:)=bathy(2,:)431 ENDIF432 IF ((nbondi == 1).OR.(nbondi == 2)) THEN433 bathy(jpi,:)=bathy(jpi-1,:)434 ENDIF435 ENDIF409 ! #if defined key_agrif 410 ! IF( lk_south ) THEN 411 ! IF( (nbondj == -1).OR.(nbondj == 2) ) THEN 412 ! bathy(:,1)=bathy(:,2) 413 ! ENDIF 414 ! ELSE 415 ! bathy(:,1) = 0. 416 ! ENDIF 417 ! #else 418 ! IF ((nbondj == -1).OR.(nbondj == 2)) THEN 419 ! bathy(:,1)=bathy(:,2) 420 ! ENDIF 421 ! #endif 422 423 ! IF ((nbondj == 1).OR.(nbondj == 2)) THEN 424 ! bathy(:,jpj)=bathy(:,jpj-1) 425 ! ENDIF 426 427 ! ! Correct West and East 428 ! IF (jperio /=1) THEN 429 ! IF ((nbondi == -1).OR.(nbondi == 2)) THEN 430 ! bathy(1,:)=bathy(2,:) 431 ! ENDIF 432 ! IF ((nbondi == 1).OR.(nbondi == 2)) THEN 433 ! bathy(jpi,:)=bathy(jpi-1,:) 434 ! ENDIF 435 ! ENDIF 436 436 437 437 -
utils/tools/DOMAINcfg/src/domcfg.f90
r13204 r14623 55 55 IF( jperio < 0 .OR. jperio > 6 ) CALL ctl_stop( 'jperio is out of range' ) 56 56 ! 57 CALL dom_glo ! global domain versus zoom and/or local domain58 !59 57 END SUBROUTINE dom_cfg 60 58 61 SUBROUTINE dom_glo62 !!----------------------------------------------------------------------63 !! *** ROUTINE dom_glo ***64 !!65 !! ** Purpose : initialization of global domain <--> local domain indices66 !!67 !! ** Method :68 !!69 !! ** Action : - mig , mjg : local domain indices ==> global domain indices70 !! - mi0 , mi1 : global domain indices ==> local domain indices71 !! - mj0,, mj1 (global point not in the local domain ==> mi0>mi1 and/or mj0>mj1)72 !!----------------------------------------------------------------------73 INTEGER :: ji, jj ! dummy loop argument74 !!----------------------------------------------------------------------75 !76 DO ji = 1, jpi ! local domain indices ==> global domain indices77 mig(ji) = ji + nimpp - 178 END DO79 DO jj = 1, jpj80 mjg(jj) = jj + njmpp - 181 END DO82 ! ! global domain indices ==> local domain indices83 ! ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the84 ! ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain.85 DO ji = 1, jpiglo86 mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) )87 mi1(ji) = MAX( 0 , MIN( ji - nimpp + 1, jpi ) )88 END DO89 DO jj = 1, jpjglo90 mj0(jj) = MAX( 1 , MIN( jj - njmpp + 1, jpj+1 ) )91 mj1(jj) = MAX( 0 , MIN( jj - njmpp + 1, jpj ) )92 END DO93 IF(lwp) THEN ! control print94 WRITE(numout,*)95 WRITE(numout,*) 'dom_glo : domain: global <<==>> local '96 WRITE(numout,*) '~~~~~~~ '97 WRITE(numout,*) ' global domain: jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpkglo = ', jpkglo98 WRITE(numout,*) ' local domain: jpi = ', jpi , ' jpj = ', jpj , ' jpk = ', jpk99 WRITE(numout,*)100 WRITE(numout,*) ' conversion from local to global domain indices (and vise versa) done'101 102 ! WRITE(numout,*)103 ! WRITE(numout,*) ' conversion local ==> global i-index domain (mig)'104 ! WRITE(numout,25) (mig(ji),ji = 1,jpi)105 ! WRITE(numout,*)106 ! WRITE(numout,*) ' conversion global ==> local i-index domain'107 ! WRITE(numout,*) ' starting index (mi0)'108 ! WRITE(numout,25) (mi0(ji),ji = 1,jpiglo)109 ! WRITE(numout,*) ' ending index (mi1)'110 ! WRITE(numout,25) (mi1(ji),ji = 1,jpiglo)111 ! WRITE(numout,*)112 ! WRITE(numout,*) ' conversion local ==> global j-index domain (mjg)'113 ! WRITE(numout,25) (mjg(jj),jj = 1,jpj)114 ! WRITE(numout,*)115 ! WRITE(numout,*) ' conversion global ==> local j-index domain'116 ! WRITE(numout,*) ' starting index (mj0)'117 ! WRITE(numout,25) (mj0(jj),jj = 1,jpjglo)118 ! WRITE(numout,*) ' ending index (mj1)'119 ! WRITE(numout,25) (mj1(jj),jj = 1,jpjglo)120 ENDIF121 25 FORMAT( 100(10x,19i4,/) )122 !123 END SUBROUTINE dom_glo124 59 !!====================================================================== 125 60 END MODULE domcfg -
utils/tools/DOMAINcfg/src/domclo.F90
r13204 r14623 93 93 !!--------------------------------------------------------------------- 94 94 95 REWIND( numnam_ref ) ! Namelist namlbc in reference namelist : Lateral momentum boundary condition95 ! REWIND( numnam_ref ) ! Namelist namlbc in reference namelist : Lateral momentum boundary condition 96 96 READ ( numnam_ref, namclo, IOSTAT = ios, ERR = 901 ) 97 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namclo in reference namelist' , lwp)98 REWIND( numnam_cfg ) ! Namelist namlbc in configuration namelist : Lateral momentum boundary condition97 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namclo in reference namelist') 98 ! REWIND( numnam_cfg ) ! Namelist namlbc in configuration namelist : Lateral momentum boundary condition 99 99 READ ( numnam_cfg, namclo, IOSTAT = ios, ERR = 902 ) 100 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namclo in configuration namelist' , lwp)100 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namclo in configuration namelist') 101 101 IF(lwm) WRITE ( numond, namclo ) 102 102 -
utils/tools/DOMAINcfg/src/domhgr.F90
r13390 r14623 392 392 IF(lwp) THEN 393 393 WRITE(numout,*) 394 WRITE(numout,*) ' Beta-plane: Beta parameter = constant = ', ff_f( nldi,nldj)395 WRITE(numout,*) ' Coriolis parameter varies from ', ff_f( nldi,nldj),' to ', ff_f(nldi,nlej)394 WRITE(numout,*) ' Beta-plane: Beta parameter = constant = ', ff_f(Nis0,Njs0) 395 WRITE(numout,*) ' Coriolis parameter varies from ', ff_f(Nis0,Njs0),' to ', ff_f(Nis0,Nje0) 396 396 ENDIF 397 397 IF( lk_mpp ) THEN 398 zminff=ff_f( nldi,nldj)399 zmaxff=ff_f( nldi,nlej)398 zminff=ff_f(Nis0,Njs0) 399 zmaxff=ff_f(Nis0,Nje0) 400 400 CALL mpp_min( 'toto',zminff ) ! min over the global domain 401 401 CALL mpp_max( 'toto',zmaxff ) ! max over the global domain … … 415 415 WRITE(numout,*) 416 416 WRITE(numout,*) ' Beta-plane and rotated domain : ' 417 WRITE(numout,*) ' Coriolis parameter varies in this processor from ', ff_f( nldi,nldj),' to ', ff_f(nldi,nlej)417 WRITE(numout,*) ' Coriolis parameter varies in this processor from ', ff_f(Nis0,Njs0),' to ', ff_f(Nis0,Nje0) 418 418 ENDIF 419 419 ! 420 420 IF( lk_mpp ) THEN 421 zminff=ff_f( nldi,nldj)422 zmaxff=ff_f( nldi,nlej)421 zminff=ff_f(Nis0,Njs0) 422 zmaxff=ff_f(Nis0,Nje0) 423 423 CALL mpp_min('toto', zminff ) ! min over the global domain 424 424 CALL mpp_max( 'toto',zmaxff ) ! max over the global domain … … 462 462 ENDIF 463 463 ! 464 464 465 IF (ln_read_cfg) THEN 465 466 coordinate_filename=TRIM(cn_domcfg) … … 469 470 CALL iom_open( coordinate_filename, inum ) 470 471 ! 471 CALL iom_get( inum, jpdom_ data, 'glamt', glamt, lrowattr=ln_use_jattr)472 CALL iom_get( inum, jpdom_ data, 'glamu', glamu, lrowattr=ln_use_jattr)473 CALL iom_get( inum, jpdom_ data, 'glamv', glamv, lrowattr=ln_use_jattr)474 CALL iom_get( inum, jpdom_ data, 'glamf', glamf, lrowattr=ln_use_jattr)475 ! 476 CALL iom_get( inum, jpdom_ data, 'gphit', gphit, lrowattr=ln_use_jattr)477 CALL iom_get( inum, jpdom_ data, 'gphiu', gphiu, lrowattr=ln_use_jattr)478 CALL iom_get( inum, jpdom_ data, 'gphiv', gphiv, lrowattr=ln_use_jattr)479 CALL iom_get( inum, jpdom_ data, 'gphif', gphif, lrowattr=ln_use_jattr)480 ! 481 CALL iom_get( inum, jpdom_ data, 'e1t' , e1t , lrowattr=ln_use_jattr)482 CALL iom_get( inum, jpdom_ data, 'e1u' , e1u , lrowattr=ln_use_jattr)483 CALL iom_get( inum, jpdom_ data, 'e1v' , e1v , lrowattr=ln_use_jattr)484 CALL iom_get( inum, jpdom_ data, 'e1f' , e1f , lrowattr=ln_use_jattr)485 ! 486 CALL iom_get( inum, jpdom_ data, 'e2t' , e2t , lrowattr=ln_use_jattr)487 CALL iom_get( inum, jpdom_ data, 'e2u' , e2u , lrowattr=ln_use_jattr)488 CALL iom_get( inum, jpdom_ data, 'e2v' , e2v , lrowattr=ln_use_jattr)489 CALL iom_get( inum, jpdom_ data, 'e2f' , e2f , lrowattr=ln_use_jattr)472 CALL iom_get( inum, jpdom_global, 'glamt', glamt, cd_type = 'T', psgn = 1._wp ) 473 CALL iom_get( inum, jpdom_global, 'glamu', glamu, cd_type = 'U', psgn = 1._wp ) 474 CALL iom_get( inum, jpdom_global, 'glamv', glamv, cd_type = 'V', psgn = 1._wp ) 475 CALL iom_get( inum, jpdom_global, 'glamf', glamf, cd_type = 'F', psgn = 1._wp ) 476 ! 477 CALL iom_get( inum, jpdom_global, 'gphit', gphit, cd_type = 'T', psgn = 1._wp ) 478 CALL iom_get( inum, jpdom_global, 'gphiu', gphiu, cd_type = 'U', psgn = 1._wp ) 479 CALL iom_get( inum, jpdom_global, 'gphiv', gphiv, cd_type = 'V', psgn = 1._wp ) 480 CALL iom_get( inum, jpdom_global, 'gphif', gphif, cd_type = 'F', psgn = 1._wp ) 481 ! 482 CALL iom_get( inum, jpdom_global, 'e1t' , e1t , cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy ) 483 CALL iom_get( inum, jpdom_global, 'e1u' , e1u , cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) 484 CALL iom_get( inum, jpdom_global, 'e1v' , e1v , cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) 485 CALL iom_get( inum, jpdom_global, 'e1f' , e1f , cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy ) 486 ! 487 CALL iom_get( inum, jpdom_global, 'e2t' , e2t , cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy ) 488 CALL iom_get( inum, jpdom_global, 'e2u' , e2u , cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) 489 CALL iom_get( inum, jpdom_global, 'e2v' , e2v , cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) 490 CALL iom_get( inum, jpdom_global, 'e2f' , e2f , cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy ) 490 491 ! 491 492 IF( iom_varid( inum, 'e1e2u', ldstop = .FALSE. ) > 0 ) THEN 492 493 IF(lwp) WRITE(numout,*) 'hgr_read : e1e2u & e1e2v read in coordinates file' 493 CALL iom_get( inum, jpdom_ data, 'e1e2u' , e1e2u , lrowattr=ln_use_jattr)494 CALL iom_get( inum, jpdom_ data, 'e1e2v' , e1e2v , lrowattr=ln_use_jattr)494 CALL iom_get( inum, jpdom_global, 'e1e2u', e1e2u, cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) 495 CALL iom_get( inum, jpdom_global, 'e1e2v', e1e2v, cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) 495 496 ke1e2u_v = 1 496 497 ELSE -
utils/tools/DOMAINcfg/src/domisf.F90
r14199 r14623 59 59 ! 60 60 ! 0.0 read namelist 61 REWIND( numnam_ref ) ! Namelist namzgr_isf in reference namelist : ice shelf geometry definition61 ! REWIND( numnam_ref ) ! Namelist namzgr_isf in reference namelist : ice shelf geometry definition 62 62 READ ( numnam_ref, namzgr_isf, IOSTAT = ios, ERR = 901) 63 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr_isf in reference namelist' , lwp)64 65 REWIND( numnam_cfg ) ! Namelist namzgr_sco in configuration namelist : ice shelf geometry definition63 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr_isf in reference namelist') 64 65 ! REWIND( numnam_cfg ) ! Namelist namzgr_sco in configuration namelist : ice shelf geometry definition 66 66 READ ( numnam_cfg, namzgr_isf, IOSTAT = ios, ERR = 902 ) 67 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr_isf in configuration namelist' , lwp)67 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr_isf in configuration namelist') 68 68 IF(lwm) WRITE ( numond, namzgr_isf ) 69 69 ! … … 295 295 zrisfdep = risfdep 296 296 WHERE ( mbathy(:,:) == 0 ) 297 imask(:,:) = jpk297 imask(:,:) = 0 298 298 imbathy(:,:) = jpk 299 299 END WHERE … … 302 302 IF( (misfdep(ji,jj) > 1) .AND. (mbathy(ji,jj) > 0) ) THEN 303 303 ! 304 ! what it should be (1 = should be connected; >= jpk = should not be connected)304 ! what it should be 305 305 imskip1 = imask(ji,jj) * imask(ji+1,jj ) ! 1 = should be connected 306 306 imskim1 = imask(ji,jj) * imask(ji-1,jj ) ! 1 = should be connected … … 308 308 imskjm1 = imask(ji,jj) * imask(ji ,jj-1) ! 1 = should be connected 309 309 ! 310 ! what it is ? ( 1 = no effective connection; jpk = effective connection )310 ! what it is 311 311 imskip1_r=jpk ; imskim1_r=jpk; imskjp1_r=jpk; imskjm1_r=jpk 312 312 IF (misfdep(ji,jj) > imbathy(ji+1,jj )) imskip1_r=1.0 ! 1 = no effective connection … … 316 316 ! 317 317 ! defining level needed for connectivity 318 ! imskip1 * imskip1_r == 1 means connection need to be enforce 319 ! imskip1 * imskip1_r >= jpk means no connection need to be enforce 318 ! imskip1 * imskip1_r == 1 means connections need to be enforce 320 319 jk=MIN(imbathy(ji+1,jj ) * imskip1_r * imskip1, & 321 320 & imbathy(ji-1,jj ) * imskim1_r * imskim1, & 322 321 & imbathy(ji ,jj+1) * imskjp1_r * imskjp1, & 323 322 & imbathy(ji ,jj-1) * imskjm1_r * imskjm1, & 324 & jpk ) ! add jpk in the MIN to avoid out of boundary later on323 & jpk+1 ) ! add jpk in the MIN to avoid out of boundary later on 325 324 ! 326 325 ! if connectivity is OK or no connection needed (grounding line) or grounded, zmisfdep=misfdep -
utils/tools/DOMAINcfg/src/dommsk.F90
r14199 r14623 98 98 !!--------------------------------------------------------------------- 99 99 ! 100 REWIND( numnam_ref ) ! Namelist namlbc in reference namelist : Lateral momentum boundary condition100 ! REWIND( numnam_ref ) ! Namelist namlbc in reference namelist : Lateral momentum boundary condition 101 101 READ ( numnam_ref, namlbc, IOSTAT = ios, ERR = 901 ) 102 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlbc in reference namelist' , lwp)103 REWIND( numnam_cfg ) ! Namelist namlbc in configuration namelist : Lateral momentum boundary condition102 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlbc in reference namelist') 103 ! REWIND( numnam_cfg ) ! Namelist namlbc in configuration namelist : Lateral momentum boundary condition 104 104 READ ( numnam_cfg, namlbc, IOSTAT = ios, ERR = 902 ) 105 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlbc in configuration namelist' , lwp)105 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlbc in configuration namelist') 106 106 IF(lwm) WRITE ( numond, namlbc ) 107 107 … … 156 156 END DO 157 157 END DO 158 ELSE158 ELSE 159 159 DO jk = 1, jpk 160 160 DO jj = 1, jpj … … 209 209 ! -------------------- 210 210 ! 211 iif = nn_hls ; iil = nlci - nn_hls + 1212 ijf = nn_hls ; ijl = nlcj - nn_hls + 1211 iif = nn_hls ; iil = jpi - nn_hls + 1 212 ijf = nn_hls ; ijl = jpj - nn_hls + 1 213 213 ! 214 214 ! ! halo mask : 0 on the halo and 1 elsewhere … … 225 225 tpol(jpiglo/2+1:jpiglo) = 0._wp 226 226 fpol( 1 :jpiglo) = 0._wp 227 IF( mjg( nlej) == jpjglo ) THEN ! only half of the nlcj-1 row for tmask_h227 IF( mjg(Nje0) == jpjglo ) THEN ! only half of the nlcj-1 row for tmask_h 228 228 DO ji = iif+1, iil-1 229 tmask_h(ji, nlej-1) = tmask_h(ji,nlej-1) * tpol(mig(ji))229 tmask_h(ji,Nje0-1) = tmask_h(ji,Nje0-1) * tpol(mig(ji)) 230 230 END DO 231 231 ENDIF … … 275 275 #if defined key_agrif 276 276 IF( .NOT. AGRIF_Root() ) THEN 277 IF(lk_east) fmask( nlci-1 , : ,jk) = 0.e0 ! east277 IF(lk_east) fmask(jpi-1 , : ,jk) = 0.e0 ! east 278 278 IF(lk_west) fmask(1 , : ,jk) = 0.e0 ! west 279 IF(lk_north) fmask(: , nlcj-1 ,jk) = 0.e0 ! north279 IF(lk_north) fmask(: ,jpj-1 ,jk) = 0.e0 ! north 280 280 IF(lk_south) fmask(: ,1 ,jk) = 0.e0 ! south 281 281 ENDIF … … 294 294 ! -------------------------------- 295 295 ! 296 ! write mesh mask 297 IF ( nn_msh > 0 ) CALL dom_wri 298 ! 296 299 297 CALL usr_def_fmask( cp_cfg, jp_cfg, fmask ) 300 298 ! -
utils/tools/DOMAINcfg/src/domngb.F90
r14199 r14623 46 46 INTEGER :: ik ! working level 47 47 INTEGER , DIMENSION(2) :: iloc 48 REAL(wp) :: zlon, zmini 48 49 REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zmask, zdist 49 50 !!-------------------------------------------------------------------- … … 53 54 IF ( PRESENT(kkk) ) ik=kkk 54 55 SELECT CASE( cdgrid ) 55 CASE( 'U' ) ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; zmask( nldi:nlei,nldj:nlej) = umask(nldi:nlei,nldj:nlej,ik)56 CASE( 'V' ) ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; zmask( nldi:nlei,nldj:nlej) = vmask(nldi:nlei,nldj:nlej,ik)57 CASE( 'F' ) ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; zmask( nldi:nlei,nldj:nlej) = fmask(nldi:nlei,nldj:nlej,ik)58 CASE DEFAULT ; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; zmask( nldi:nlei,nldj:nlej) = tmask(nldi:nlei,nldj:nlej,ik)56 CASE( 'U' ) ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; zmask(Nis0:Nie0,Njs0:Nje0) = umask(Nis0:Nie0,Njs0:Nje0,ik) 57 CASE( 'V' ) ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; zmask(Nis0:Nie0,Njs0:Nje0) = vmask(Nis0:Nie0,Njs0:Nje0,ik) 58 CASE( 'F' ) ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; zmask(Nis0:Nie0,Njs0:Nje0) = fmask(Nis0:Nie0,Njs0:Nje0,ik) 59 CASE DEFAULT ; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; zmask(Nis0:Nie0,Njs0:Nje0) = tmask(Nis0:Nie0,Njs0:Nje0,ik) 59 60 END SELECT 60 61 61 zdist = dist(plon, plat, zglam, zgphi) 62 zlon = MOD( plon + 720., 360. ) ! plon between 0 and 360 63 zglam(:,:) = MOD( zglam(:,:) + 720., 360. ) ! glam between 0 and 360 64 IF( zlon > 270. ) zlon = zlon - 360. ! zlon between -90 and 270 65 IF( zlon < 90. ) WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360. ! glam between -180 and 180 66 zglam(:,:) = zglam(:,:) - zlon 62 67 63 68 IF( lk_mpp ) THEN -
utils/tools/DOMAINcfg/src/domwri.F90
r14199 r14623 215 215 lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed 216 216 ! 217 puniq(:,:) = REAL( COUNT( lldbl(:,:,:), dim = 3 ) , wp ) 217 puniq(:,:) = 1. ! default definition 218 ! fill only the inner part of the cpu with llbl converted into real 219 puniq(Nis0:Nie0,Njs0:Nje0) = REAL( COUNT( lldbl(Nis0:Nie0,Njs0:Nje0,:), dim = 3 ) , wp ) 218 220 ! 219 221 END SUBROUTINE dom_uniq -
utils/tools/DOMAINcfg/src/domzgr.F90
r13390 r14623 75 75 REAL(wp) :: rn_zb_b ! offset for calculating Zb 76 76 77 !! * Substitutions 77 !! * Substitutions 78 # include "do_loop_substitute.h90" 78 79 !!---------------------------------------------------------------------- 79 !! *** vectopt_loop_substitute *** 80 !!---------------------------------------------------------------------- 81 !! ** purpose : substitute the inner loop start/end indices with CPP macro 82 !! allow unrolling of do-loop (useful with vector processors) 83 !!---------------------------------------------------------------------- 84 !!---------------------------------------------------------------------- 85 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 86 !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $ 87 !! Software governed by the CeCILL licence (./LICENSE) 88 !!---------------------------------------------------------------------- 89 !!---------------------------------------------------------------------- 90 !! NEMO/OPA 3.3.1 , NEMO Consortium (2011) 91 !! $Id: domzgr.F90 6827 2016-08-01 13:37:15Z flavoni $ 92 !! Software governed by the CeCILL licence (./LICENSE) 80 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 81 !! $Id: dommsk.F90 13305 2020-07-14 17:12:25Z acc $ 82 !! Software governed by the CeCILL license (see ./LICENSE) 93 83 !!---------------------------------------------------------------------- 94 84 CONTAINS … … 124 114 ! 125 115 ! 126 REWIND( numnam_ref ) ! Namelist namzgr in reference namelist : Vertical coordinate116 ! REWIND( numnam_ref ) ! Namelist namzgr in reference namelist : Vertical coordinate 127 117 READ ( numnam_ref, namzgr, IOSTAT = ios, ERR = 901 ) 128 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in reference namelist' , lwp)129 130 REWIND( numnam_cfg ) ! Namelist namzgr in configuration namelist : Vertical coordinate118 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in reference namelist') 119 120 ! REWIND( numnam_cfg ) ! Namelist namzgr in configuration namelist : Vertical coordinate 131 121 READ ( numnam_cfg, namzgr, IOSTAT = ios, ERR = 902 ) 132 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in configuration namelist' , lwp)122 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in configuration namelist') 133 123 IF(lwm) WRITE ( numond, namzgr ) 134 124 … … 279 269 CALL iom_get( inum, jpdom_unknown, 'e3w_1d' , pe3w_1d ) 280 270 ! 281 CALL iom_get( inum, jpdom_ data, 'e3t_0' , pe3t , lrowattr=ln_use_jattr) ! 3D coordinate282 CALL iom_get( inum, jpdom_ data, 'e3u_0' , pe3u , lrowattr=ln_use_jattr)283 CALL iom_get( inum, jpdom_ data, 'e3v_0' , pe3v , lrowattr=ln_use_jattr)284 CALL iom_get( inum, jpdom_ data, 'e3f_0' , pe3f , lrowattr=ln_use_jattr)285 CALL iom_get( inum, jpdom_ data, 'e3w_0' , pe3w , lrowattr=ln_use_jattr)286 CALL iom_get( inum, jpdom_ data, 'e3uw_0' , pe3uw , lrowattr=ln_use_jattr)287 CALL iom_get( inum, jpdom_ data, 'e3vw_0' , pe3vw , lrowattr=ln_use_jattr)271 CALL iom_get( inum, jpdom_global, 'e3t_0' , pe3t , cd_type = 'T', psgn = 1._wp, kfill = jpfillcopy ) ! 3D coordinate 272 CALL iom_get( inum, jpdom_global, 'e3u_0' , pe3u , cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) 273 CALL iom_get( inum, jpdom_global, 'e3v_0' , pe3v , cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) 274 CALL iom_get( inum, jpdom_global, 'e3f_0' , pe3f , cd_type = 'F', psgn = 1._wp, kfill = jpfillcopy ) 275 CALL iom_get( inum, jpdom_global, 'e3w_0' , pe3w , cd_type = 'W', psgn = 1._wp, kfill = jpfillcopy ) 276 CALL iom_get( inum, jpdom_global, 'e3uw_0' , pe3uw, cd_type = 'U', psgn = 1._wp, kfill = jpfillcopy ) 277 CALL iom_get( inum, jpdom_global, 'e3vw_0' , pe3vw, cd_type = 'V', psgn = 1._wp, kfill = jpfillcopy ) 288 278 ! 289 279 ! !* depths … … 297 287 CALL iom_get( inum, jpdom_unknown, 'gdept_1d', pdept_1d ) 298 288 CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', pdepw_1d ) 299 CALL iom_get( inum, jpdom_ data , 'gdept_0' , pdept , lrowattr=ln_use_jattr)300 CALL iom_get( inum, jpdom_ data , 'gdepw_0' , pdepw , lrowattr=ln_use_jattr)289 CALL iom_get( inum, jpdom_global , 'gdept_0' , pdept, kfill = jpfillcopy ) 290 CALL iom_get( inum, jpdom_global , 'gdepw_0' , pdepw, kfill = jpfillcopy ) 301 291 ! 302 292 ELSE !- depths computed from e3. scale factors … … 312 302 ! 313 303 ! !* ocean top and bottom level 314 CALL iom_get( inum, jpdom_ data, 'top_level' , z2d , lrowattr=ln_use_jattr) ! 1st wet T-points (ISF)304 CALL iom_get( inum, jpdom_global, 'top_level' , z2d ) ! 1st wet T-points (ISF) 315 305 k_top(:,:) = NINT( z2d(:,:) ) 316 CALL iom_get( inum, jpdom_ data, 'bottom_level' , z2d , lrowattr=ln_use_jattr) ! last wet T-points306 CALL iom_get( inum, jpdom_global, 'bottom_level' , z2d ) ! last wet T-points 317 307 k_bot(:,:) = NINT( z2d(:,:) ) 318 308 ! … … 660 650 mbathy(:,:) = 0 ! set to zero extra halo points 661 651 bathy (:,:) = 0._wp ! (require for mpp case) 662 DO jj = 1, nlcj ! interior values 663 DO ji = 1, nlci 652 DO_2D( 0, 0, 0, 0 ) 664 653 mbathy(ji,jj) = idta( mig(ji), mjg(jj) ) 665 654 bathy (ji,jj) = zdta( mig(ji), mjg(jj) ) 666 END DO 667 END DO 655 END_2D 668 656 risfdep(:,:)=0.e0 669 657 misfdep(:,:)=1 … … 677 665 IF( ln_zco ) THEN ! zco : read level bathymetry 678 666 CALL iom_open ( cn_topolvl, inum ) 679 CALL iom_get ( inum, jpdom_ data, cn_bathlvl, bathy )667 CALL iom_get ( inum, jpdom_auto, cn_bathlvl, bathy ) 680 668 CALL iom_close( inum ) 681 669 mbathy(:,:) = INT( bathy(:,:) ) … … 715 703 IF( ntopo == 1) THEN 716 704 CALL iom_open ( cn_topo, inum ) 717 CALL iom_get ( inum, jpdom_ data, cn_bath, bathy, lrowattr=ln_use_jattr)705 CALL iom_get ( inum, jpdom_auto, cn_bath, bathy ) 718 706 CALL iom_close( inum ) 719 707 ELSE … … 735 723 IF ( ln_isfcav ) THEN 736 724 CALL iom_open ( cn_fisfd, inum ) 737 CALL iom_get ( inum, jpdom_ data, cn_visfd, risfdep )725 CALL iom_get ( inum, jpdom_auto, cn_visfd, risfdep ) 738 726 CALL iom_close( inum ) 739 727 END IF … … 857 845 ENDIF 858 846 ! ! East-west cyclic boundary conditions 847 859 848 IF( jperio == 0 ) THEN 860 849 IF(lwp) WRITE(numout,*) ' mbathy set to 0 along east and west boundary: jperio = ', jperio 861 IF( lk_mpp ) THEN 862 IF( nbondi == -1 .OR. nbondi == 2 ) THEN 863 IF( jperio /= 1 ) mbathy(1,:) = 0 864 ENDIF 865 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 866 IF( jperio /= 1 ) mbathy(nlci,:) = 0 867 ENDIF 850 IF( ln_zco .OR. ln_zps ) THEN 851 mbathy( mi0( 1+nn_hls):mi1( 1+nn_hls),:) = 0 852 mbathy( mi0(jpiglo-nn_hls):mi1(jpiglo-nn_hls),:) = 0 868 853 ELSE 869 IF( ln_zco .OR. ln_zps ) THEN 870 mbathy( 1 ,:) = 0 871 mbathy(jpi,:) = 0 872 ELSE 873 mbathy( 1 ,:) = jpkm1 874 mbathy(jpi,:) = jpkm1 875 ENDIF 854 mbathy( mi0( 1+nn_hls):mi1( 1+nn_hls),:) = jpkm1 855 mbathy( mi0(jpiglo-nn_hls):mi1(jpiglo-nn_hls),:) = jpkm1 876 856 ENDIF 877 857 ELSEIF( l_Iperio ) THEN … … 898 878 ! Number of ocean level inferior or equal to jpkm1 899 879 zbathy(:,:) = FLOAT( mbathy(:,:) ) 900 ikmax = glob_max( 'domzgr', zbathy(:,:) ) 880 ikmax = MAXVAL(zbathy(:,:)) 881 CALL mpp_max( 'domzgr',ikmax) 901 882 902 883 IF( ikmax > jpkm1 ) THEN … … 1308 1289 ALLOCATE( zenv(jpi,jpj), ztmp(jpi,jpj), zmsk(jpi,jpj), zri(jpi,jpj), zrj(jpi,jpj), zhbat(jpi,jpj) , ztmpi1(jpi,jpj), ztmpi2(jpi,jpj), ztmpj1(jpi,jpj), ztmpj2(jpi,jpj) ) 1309 1290 ! 1310 REWIND( numnam_ref ) ! Namelist namzgr_sco in reference namelist : Sigma-stretching parameters1291 !REWIND( numnam_ref ) ! Namelist namzgr_sco in reference namelist : Sigma-stretching parameters 1311 1292 READ ( numnam_ref, namzgr_sco, IOSTAT = ios, ERR = 901) 1312 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr_sco in reference namelist' , lwp)1313 1314 REWIND( numnam_cfg ) ! Namelist namzgr_sco in configuration namelist : Sigma-stretching parameters1293 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr_sco in reference namelist') 1294 1295 !REWIND( numnam_cfg ) ! Namelist namzgr_sco in configuration namelist : Sigma-stretching parameters 1315 1296 READ ( numnam_cfg, namzgr_sco, IOSTAT = ios, ERR = 902 ) 1316 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr_sco in configuration namelist' , lwp)1297 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr_sco in configuration namelist') 1317 1298 IF(lwm) WRITE ( numond, namzgr_sco ) 1318 1299 … … 1386 1367 1387 1368 ! apply lateral boundary condition CAUTION: keep the value when the lbc field is zero 1388 CALL lbc_lnk( 'domzgr',zenv, 'T', 1._wp, 'no0')1369 CALL lbc_lnk( 'domzgr',zenv, 'T', 1._wp, kfillmode=jpfillnothing ) 1389 1370 ! 1390 1371 ! smooth the bathymetry (if required) … … 1417 1398 ! we could exit DO WHILE prematurely before checking r-value 1418 1399 ! of current zenv 1419 DO jj = 1, nlcj 1420 DO ji = 1, nlci 1400 DO_2D( 0, 0, 0, 0 ) 1421 1401 zrmax = MAX( zrmax, ABS(zri(ji,jj)), ABS(zrj(ji,jj)) ) 1422 END DO 1423 END DO 1402 END_2D 1424 1403 zri(:,:) = 0._wp 1425 1404 zrj(:,:) = 0._wp 1426 DO jj = 1, nlcj 1427 DO ji = 1, nlci 1428 iip1 = MIN( ji+1, nlci ) ! force zri = 0 on last line (ji=ncli+1 to jpi) 1429 ijp1 = MIN( jj+1, nlcj ) ! force zrj = 0 on last raw (jj=nclj+1 to jpj) 1405 DO_2D( 0, 0, 0, 0 ) 1406 iip1 = MIN( ji+1, jpi ) ! force zri = 0 on last line (ji=ncli+1 to jpi) 1407 ijp1 = MIN( jj+1, jpj ) ! force zrj = 0 on last raw (jj=nclj+1 to jpj) 1430 1408 IF( (zenv(ji,jj) > 0._wp) .AND. (zenv(iip1,jj) > 0._wp)) THEN 1431 1409 zri(ji,jj) = ( zenv(iip1,jj ) - zenv(ji,jj) ) / ( zenv(iip1,jj ) + zenv(ji,jj) ) … … 1438 1416 IF( zrj(ji,jj) > rn_rmax ) ztmpj1(ji ,jj ) = zenv(ji ,ijp1) * zrfact 1439 1417 IF( zrj(ji,jj) < -rn_rmax ) ztmpj2(ji ,ijp1) = zenv(ji ,jj ) * zrfact 1440 END DO 1441 END DO 1418 END_2D 1442 1419 ! IF( lk_mpp ) CALL mpp_max( zrmax ) ! max over the global domain 1443 1420 ! 1444 1421 IF(lwp)WRITE(numout,*) 'zgr_sco : iter= ',jl, ' rmax= ', zrmax 1445 1422 ! 1446 DO jj = 1, nlcj 1447 DO ji = 1, nlci 1423 DO_2D( 0, 0, 0, 0 ) 1448 1424 zenv(ji,jj) = MAX(zenv(ji,jj), ztmpi1(ji,jj), ztmpi2(ji,jj), ztmpj1(ji,jj), ztmpj2(ji,jj) ) 1449 END DO 1450 END DO 1425 END_2D 1451 1426 ! apply lateral boundary condition CAUTION: keep the value when the lbc field is zero 1452 CALL lbc_lnk( 'toto',zenv, 'T', 1._wp, 'no0')1427 CALL lbc_lnk( 'toto',zenv, 'T', 1._wp, kfillmode=jpfillnothing) 1453 1428 ! ! ================ ! 1454 1429 END DO ! End loop ! -
utils/tools/DOMAINcfg/src/errioipsl.f90
r6951 r14623 1 1 MODULE errioipsl 2 !$AGRIF_DO_NOT_TREAT 2 3 !- 3 4 !$Id: errioipsl.f90 2281 2010-10-15 14:21:13Z smasson $ … … 213 214 !=== 214 215 !------------------- 216 !$AGRIF_END_DO_NOT_TREAT 215 217 END MODULE errioipsl -
utils/tools/DOMAINcfg/src/in_out_manager.F90
r13204 r14623 22 22 !!---------------------------------------------------------------------- 23 23 CHARACTER(lc) :: cn_exp !: experiment name used for output filename 24 CHARACTER(lc) :: cn_ocerst_in !: suffix of ocean restart name (input) 25 CHARACTER(lc) :: cn_ocerst_indir !: restart input directory 26 CHARACTER(lc) :: cn_ocerst_out !: suffix of ocean restart name (output) 27 CHARACTER(lc) :: cn_ocerst_outdir !: restart output directory 28 LOGICAL :: ln_rstart !: start from (F) rest or (T) a restart file 29 LOGICAL :: ln_rst_list !: output restarts at list of times (T) or by frequency (F) 30 INTEGER :: nn_rstctl !: control of the time step (0, 1 or 2) 31 INTEGER :: nn_rstssh = 0 !: hand made initilization of ssh or not (1/0) 24 32 INTEGER :: nn_it000 !: index of the first time step 25 33 INTEGER :: nn_itend !: index of the last time step … … 27 35 INTEGER :: nn_time0 !: initial time of day in hhmm 28 36 INTEGER :: nn_leapy !: Leap year calendar flag (0/1 or 30) 37 INTEGER :: nn_istate !: initial state output flag (0/1) 38 INTEGER :: nn_write !: model standard output frequency 39 INTEGER :: nn_stock !: restart file frequency 40 INTEGER, DIMENSION(10) :: nn_stocklist !: restart dump times 29 41 LOGICAL :: ln_mskland !: mask land points in NetCDF outputs (costly: + ~15%) 30 42 LOGICAL :: ln_cfmeta !: output additional data to netCDF files required for compliance with the CF metadata standard … … 33 45 LOGICAL :: ln_xios_read !: use xios to read single file restart 34 46 INTEGER :: nn_wxios !: write resart using xios 0 - no, 1 - single, 2 - multiple file output 47 INTEGER :: nn_no !: Assimilation cycle 35 48 36 49 #if defined key_netcdf4 … … 61 74 62 75 CHARACTER(lc) :: cexper !: experiment name used for output filename 76 INTEGER :: nrstdt !: control of the time step (0, 1 or 2) 63 77 INTEGER :: nit000 !: index of the first time step 64 78 INTEGER :: nitend !: index of the last time step 65 79 INTEGER :: ndate0 !: initial calendar date aammjj 66 80 INTEGER :: nleapy !: Leap year calendar flag (0/1 or 30) 81 INTEGER :: ninist !: initial state output flag (0/1) 82 83 !!---------------------------------------------------------------------- 84 !! was in restart but moved here because of the OFF line... better solution should be found... 85 !!---------------------------------------------------------------------- 86 INTEGER :: nitrst !: time step at which restart file should be written 87 LOGICAL :: lrst_oce !: logical to control the oce restart write 88 LOGICAL :: lrst_ice !: logical to control the ice restart write 89 LOGICAL :: lrst_abl !: logical to control the abl restart write 90 INTEGER :: numror = 0 !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) 91 INTEGER :: numrir !: logical unit for ice restart (read) 92 INTEGER :: numrar !: logical unit for abl restart (read) 93 INTEGER :: numrow !: logical unit for ocean restart (write) 94 INTEGER :: numriw !: logical unit for ice restart (write) 95 INTEGER :: numraw !: logical unit for abl restart (write) 96 INTEGER :: nrst_lst !: number of restart to output next 97 98 !!---------------------------------------------------------------------- 99 !! output monitoring 100 !!---------------------------------------------------------------------- 101 TYPE :: sn_ctl !: structure for control over output selection 102 LOGICAL :: l_runstat = .FALSE. !: Produce/do not produce run.stat file (T/F) 103 LOGICAL :: l_trcstat = .FALSE. !: Produce/do not produce tracer.stat file (T/F) 104 LOGICAL :: l_oceout = .FALSE. !: Produce all ocean.outputs (T) or just one (F) 105 LOGICAL :: l_layout = .FALSE. !: Produce all layout.dat files (T) or just one (F) 106 LOGICAL :: l_prtctl = .FALSE. !: Produce/do not produce mpp.output_XXXX files (T/F) 107 LOGICAL :: l_prttrc = .FALSE. !: Produce/do not produce mpp.top.output_XXXX files (T/F) 108 LOGICAL :: l_oasout = .FALSE. !: Produce/do not write oasis setup info to ocean.output (T/F) 109 ! Optional subsetting of processor report files 110 ! Default settings of 0/1000000/1 should ensure all areas report. 111 ! Set to a more restrictive range to select specific areas 112 INTEGER :: procmin = 0 !: Minimum narea to output 113 INTEGER :: procmax = 1000000 !: Maximum narea to output 114 INTEGER :: procincr = 1 !: narea increment to output 115 INTEGER :: ptimincr = 1 !: timestep increment to output (time.step and run.stat) 116 END TYPE 117 TYPE(sn_ctl), SAVE :: sn_cfctl !: run control structure for selective output, must have SAVE for default init. of sn_ctl 118 LOGICAL :: ln_timing !: run control for timing 119 LOGICAL :: ln_diacfl !: flag whether to create CFL diagnostics 120 INTEGER :: nn_ictls !: Start i indice for the SUM control 121 INTEGER :: nn_ictle !: End i indice for the SUM control 122 INTEGER :: nn_jctls !: Start j indice for the SUM control 123 INTEGER :: nn_jctle !: End j indice for the SUM control 124 INTEGER :: nn_isplt !: number of processors following i 125 INTEGER :: nn_jsplt !: number of processors following j 67 126 68 127 !!---------------------------------------------------------------------- … … 74 133 INTEGER :: numnul = -1 !: logical unit for /dev/null 75 134 ! ! early output can be collected; do not change 76 INTEGER :: numnam_ref = -1 !: logical unit for reference namelist77 INTEGER :: numnam_cfg = -1 !: logical unit for configuration specific namelist78 135 INTEGER :: numond = -1 !: logical unit for Output Namelist Dynamics 79 136 INTEGER :: numoni = -1 !: logical unit for Output Namelist Ice 137 INTEGER :: numevo_ice = -1 !: logical unit for ice variables (temp. evolution) 80 138 INTEGER :: numrun = -1 !: logical unit for run statistics 139 INTEGER :: numdct_in = -1 !: logical unit for transports computing 140 INTEGER :: numdct_vol = -1 !: logical unit for volume transports output 141 INTEGER :: numdct_heat = -1 !: logical unit for heat transports output 142 INTEGER :: numdct_salt = -1 !: logical unit for salt transports output 143 INTEGER :: numfl = -1 !: logical unit for floats ascii output 144 INTEGER :: numflo = -1 !: logical unit for floats ascii output 145 ! 146 CHARACTER(LEN=:), ALLOCATABLE :: numnam_ref !: character buffer for reference namelist 147 CHARACTER(LEN=:), ALLOCATABLE :: numnam_cfg !: character buffer for configuration specific namelist 148 CHARACTER(LEN=:), ALLOCATABLE :: numnam_ice_ref !: character buffer for ice reference namelist 149 CHARACTER(LEN=:), ALLOCATABLE :: numnam_ice_cfg !: character buffer for ice configuration specific namelist 81 150 82 151 !!---------------------------------------------------------------------- … … 85 154 INTEGER :: no_print = 0 !: optional argument of fld_fill (if present, suppress some control print) 86 155 INTEGER :: nstop = 0 !: error flag (=number of reason for a premature stop run) 156 !$AGRIF_DO_NOT_TREAT 157 INTEGER :: ngrdstop = -1 !: grid number having nstop > 1 158 !$AGRIF_END_DO_NOT_TREAT 87 159 INTEGER :: nwarn = 0 !: warning flag (=number of warning found during the run) 88 160 CHARACTER(lc) :: ctmp1, ctmp2, ctmp3 !: temporary characters 1 to 3 … … 90 162 CHARACTER(lc) :: ctmp7, ctmp8, ctmp9 !: temporary characters 7 to 9 91 163 CHARACTER(lc) :: ctmp10 !: temporary character 10 92 CHARACTER(lc) :: cform_err = "(/,' ===>>> : E R R O R', /,' ===========',/)" !:93 CHARACTER(lc) :: cform_war = "(/,' ===>>> : W A R N I N G', /,' ===============',/)" !:94 164 LOGICAL :: lwm = .FALSE. !: boolean : true on the 1st processor only (always) 95 LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only .OR. ln_ctl 165 LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only .OR. sn_cfctl%l_oceout=T 166 LOGICAL :: lsp_area = .TRUE. !: to make a control print over a specific area 96 167 CHARACTER(lc) :: cxios_context !: context name used in xios 97 168 CHARACTER(lc) :: crxios_context !: context name used in xios to read restart 98 169 CHARACTER(lc) :: cwxios_context !: context name used in xios to write restart file 99 170 171 !! * Substitutions 172 # include "do_loop_substitute.h90" 100 173 !!---------------------------------------------------------------------- 101 174 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 102 !! $Id: in_out_manager.F90 1 0570 2019-01-24 15:14:49Z acc$175 !! $Id: in_out_manager.F90 13286 2020-07-09 15:48:29Z smasson $ 103 176 !! Software governed by the CeCILL license (see ./LICENSE) 104 177 !!===================================================================== -
utils/tools/DOMAINcfg/src/ioipsl.f90
r13204 r14623 1 1 MODULE ioipsl 2 !$AGRIF_DO_NOT_TREAT 2 3 ! 3 4 !$Id: ioipsl.f90 2281 2010-10-15 14:21:13Z smasson $ … … 6 7 ! See IOIPSL/IOIPSL_License_CeCILL.txt 7 8 ! 8 USE errioipsl 9 USE errioipsl 10 USE stringop 11 USE mathelp 12 USE getincom 9 13 USE calendar 10 USE stringop 11 14 USE fliocom 15 USE flincom 16 USE histcom 17 USE restcom 18 !$AGRIF_END_DO_NOT_TREAT 12 19 END MODULE ioipsl -
utils/tools/DOMAINcfg/src/iom.F90
r14243 r14623 21 21 !!---------------------------------------------------------------------- 22 22 USE dom_oce ! ocean space and time domain 23 USE domutl ! 24 !USE c1d ! 1D vertical configuration 25 !USE flo_oce ! floats module declarations 23 26 USE lbclnk ! lateal boundary condition / mpp exchanges 24 27 USE iom_def ! iom variables definitions … … 26 29 USE in_out_manager ! I/O manager 27 30 USE lib_mpp ! MPP library 28 #if defined key_xios 29 USE sbc_oce , ONLY : nn_fsbc ! ocean space and time domain 30 USE trc_oce , ONLY : nn_dttrc ! !: frequency of step on passive tracers 31 #if defined key_iomput 32 USE sbc_oce , ONLY : nn_fsbc, ght_abl, ghw_abl, e3t_abl, e3w_abl, jpka, jpkam1 31 33 USE icb_oce , ONLY : nclasses, class_num ! !: iceberg classes 32 34 #if defined key_si3 33 35 USE ice , ONLY : jpl 34 36 #endif 35 USE domngb ! ocean space and time domain36 37 USE phycst ! physical constants 38 USE dianam ! build name of file 37 39 USE xios 38 40 # endif 39 41 USE ioipsl, ONLY : ju2ymds ! for calendar 42 ! USE crs ! Grid coarsening 40 43 #if defined key_top 41 44 USE trc, ONLY : profsed 42 45 #endif 43 46 USE lib_fortran 47 !USE diu_bulk, ONLY : ln_diurnal_only, ln_diurnal 44 48 45 49 IMPLICIT NONE 46 50 PUBLIC ! must be public to be able to access iom_def through iom 47 51 48 #if defined key_ xios52 #if defined key_iomput 49 53 LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .TRUE. !: iom_put flag 50 54 #else 51 55 LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .FALSE. !: iom_put flag 52 56 #endif 53 PUBLIC iom_init, iom_ swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get57 PUBLIC iom_init, iom_init_closedef, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get, iom_get_var 54 58 PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put 55 PUBLIC iom_use, iom_context_finalize 56 57 PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 58 PRIVATE iom_g0d, iom_g1d, iom_g2d, iom_g3d, iom_get_123d 59 PRIVATE iom_p1d, iom_p2d, iom_p3d 60 #if defined key_xios 59 PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val 60 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 68 #if defined key_iomput 61 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 62 PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_ update_file_name, iom_sdate70 PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_sdate 63 71 PRIVATE iom_set_rst_context, iom_set_rstw_active, iom_set_rstr_active 64 72 # endif 65 PUBLIC iom_set_rstw_var_active, iom_set_rst _vars73 PUBLIC iom_set_rstw_var_active, iom_set_rstw_core, iom_set_rst_vars 66 74 67 75 INTERFACE iom_get 68 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 69 78 END INTERFACE 70 79 INTERFACE iom_getatt … … 75 84 END INTERFACE 76 85 INTERFACE iom_rstput 77 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 78 88 END INTERFACE 79 89 INTERFACE iom_put 80 MODULE PROCEDURE iom_p0d, iom_p1d, iom_p2d, iom_p3d 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 81 92 END INTERFACE iom_put 82 93 94 !! * Substitutions 95 # include "do_loop_substitute.h90" 83 96 !!---------------------------------------------------------------------- 84 97 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 85 !! $Id: iom.F90 1 0523 2019-01-16 09:36:03Z smasson$98 !! $Id: iom.F90 13295 2020-07-10 18:24:21Z acc $ 86 99 !! Software governed by the CeCILL license (see ./LICENSE) 87 100 !!---------------------------------------------------------------------- 88 101 CONTAINS 89 102 90 SUBROUTINE iom_init( cdname, fname, ld_ tmppatch)103 SUBROUTINE iom_init( cdname, fname, ld_closedef ) 91 104 !!---------------------------------------------------------------------- 92 105 !! *** ROUTINE *** … … 97 110 CHARACTER(len=*), INTENT(in) :: cdname 98 111 CHARACTER(len=*), OPTIONAL, INTENT(in) :: fname 99 LOGICAL , OPTIONAL, INTENT(in) :: ld_ tmppatch100 #if defined key_ xios112 LOGICAL , OPTIONAL, INTENT(in) :: ld_closedef 113 #if defined key_iomput 101 114 ! 102 115 TYPE(xios_duration) :: dtime = xios_duration(0, 0, 0, 0, 0, 0) 103 116 TYPE(xios_date) :: start_date 104 117 CHARACTER(len=lc) :: clname 105 INTEGER :: ji, jkmin 118 INTEGER :: irefyear, irefmonth, irefday 119 INTEGER :: ji 106 120 LOGICAL :: llrst_context ! is context related to restart 107 121 ! 108 122 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds 109 LOGICAL :: ll_tmppatch = .TRUE. !: seb: patch before we remove periodicity 110 INTEGER :: nldi_save, nlei_save !: and close boundaries in output files 111 INTEGER :: nldj_save, nlej_save !: 112 !!---------------------------------------------------------------------- 113 ! 114 ! seb: patch before we remove periodicity and close boundaries in output files 115 IF( PRESENT(ld_tmppatch) ) THEN ; ll_tmppatch = ld_tmppatch 116 ELSE ; ll_tmppatch = .TRUE. 117 ENDIF 118 IF ( ll_tmppatch ) THEN 119 nldi_save = nldi ; nlei_save = nlei 120 nldj_save = nldj ; nlej_save = nlej 121 IF( nimpp == 1 ) nldi = 1 122 IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi 123 IF( njmpp == 1 ) nldj = 1 124 IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj 125 ENDIF 123 REAL(wp), DIMENSION(2,jpkam1) :: za_bnds ! ABL vertical boundaries 124 LOGICAL :: ll_closedef = .TRUE. 125 !!---------------------------------------------------------------------- 126 ! 127 IF ( PRESENT(ld_closedef) ) ll_closedef = ld_closedef 126 128 ! 127 129 ALLOCATE( zt_bnds(2,jpk), zw_bnds(2,jpk) ) … … 134 136 135 137 ! Calendar type is now defined in xml file 138 IF (.NOT.(xios_getvar('ref_year' ,irefyear ))) irefyear = 1900 139 IF (.NOT.(xios_getvar('ref_month',irefmonth))) irefmonth = 01 140 IF (.NOT.(xios_getvar('ref_day' ,irefday ))) irefday = 01 141 136 142 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL 137 CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(1900,01,01,00,00,00),&138 & start_date = xios_date(nyear,nmonth,nday,0,0,0) )139 CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(1900,01,01,00,00,00),&140 & start_date = xios_date(nyear,nmonth,nday,0,0,0) )141 CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(1900,01,01,00,00,00),&142 & start_date = xios_date(nyear,nmonth,nday,0,0,0) )143 CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & 144 & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) 145 CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & 146 & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) 147 CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & 148 & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) 143 149 END SELECT 144 150 … … 154 160 ! 155 161 IF( ln_cfmeta ) THEN ! Add additional grid metadata 156 CALL iom_set_domain_attr("grid_T", area = e1e2t(nldi:nlei, nldj:nlej))157 CALL iom_set_domain_attr("grid_U", area = e1e2u(nldi:nlei, nldj:nlej))158 CALL iom_set_domain_attr("grid_V", area = e1e2v(nldi:nlei, nldj:nlej))159 CALL iom_set_domain_attr("grid_W", area = e1e2t(nldi:nlei, nldj:nlej))162 CALL iom_set_domain_attr("grid_T", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 163 CALL iom_set_domain_attr("grid_U", area = real( e1e2u(Nis0:Nie0, Njs0:Nje0), dp)) 164 CALL iom_set_domain_attr("grid_V", area = real( e1e2v(Nis0:Nie0, Njs0:Nje0), dp)) 165 CALL iom_set_domain_attr("grid_W", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 160 166 CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 161 167 CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) … … 177 183 ! 178 184 IF( ln_cfmeta .AND. .NOT. llrst_context) THEN ! Add additional grid metadata 179 CALL iom_set_domain_attr("grid_T", area = e1e2t_crs(nldi:nlei, nldj:nlej))180 CALL iom_set_domain_attr("grid_U", area = e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej))181 CALL iom_set_domain_attr("grid_V", area = e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej))182 CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(nldi:nlei, nldj:nlej))185 CALL iom_set_domain_attr("grid_T", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp)) 186 CALL iom_set_domain_attr("grid_U", area = real(e1u_crs(Nis0:Nie0, Njs0:Nje0) * e2u_crs(Nis0:Nie0, Njs0:Nje0), dp)) 187 CALL iom_set_domain_attr("grid_V", area = real(e1v_crs(Nis0:Nie0, Njs0:Nje0) * e2v_crs(Nis0:Nie0, Njs0:Nje0), dp)) 188 CALL iom_set_domain_attr("grid_W", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp)) 183 189 CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 184 190 CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) … … 190 196 ! vertical grid definition 191 197 IF(.NOT.llrst_context) THEN 192 CALL iom_set_axis_attr( "deptht", paxis = gdept_1d ) 193 CALL iom_set_axis_attr( "depthu", paxis = gdept_1d ) 194 CALL iom_set_axis_attr( "depthv", paxis = gdept_1d ) 195 CALL iom_set_axis_attr( "depthw", paxis = gdepw_1d ) 196 198 CALL iom_set_axis_attr( "deptht", paxis = gdept_1d ) 199 CALL iom_set_axis_attr( "depthu", paxis = gdept_1d ) 200 CALL iom_set_axis_attr( "depthv", paxis = gdept_1d ) 201 CALL iom_set_axis_attr( "depthw", paxis = gdepw_1d ) 202 203 ! ABL 204 IF( .NOT. ALLOCATED(ght_abl) ) THEN ! force definition for xml files (xios) 205 ALLOCATE( ght_abl(jpka), ghw_abl(jpka), e3t_abl(jpka), e3w_abl(jpka) ) ! default allocation needed by iom 206 ght_abl(:) = -1._wp ; ghw_abl(:) = -1._wp 207 e3t_abl(:) = -1._wp ; e3w_abl(:) = -1._wp 208 ENDIF 209 CALL iom_set_axis_attr( "ght_abl", ght_abl(2:jpka) ) 210 CALL iom_set_axis_attr( "ghw_abl", ghw_abl(2:jpka) ) 211 197 212 ! Add vertical grid bounds 198 jkmin = MIN(2,jpk) ! in case jpk=1 (i.e. sas2D) 199 zt_bnds(2,: ) = gdept_1d(:) 200 zt_bnds(1,jkmin:jpk) = gdept_1d(1:jpkm1) 201 zt_bnds(1,1 ) = gdept_1d(1) - e3w_1d(1) 202 zw_bnds(1,: ) = gdepw_1d(:) 203 zw_bnds(2,1:jpkm1 ) = gdepw_1d(jkmin:jpk) 204 zw_bnds(2,jpk: ) = gdepw_1d(jpk) + e3t_1d(jpk) 205 CALL iom_set_axis_attr( "deptht", bounds=zw_bnds ) 206 CALL iom_set_axis_attr( "depthu", bounds=zw_bnds ) 207 CALL iom_set_axis_attr( "depthv", bounds=zw_bnds ) 208 CALL iom_set_axis_attr( "depthw", bounds=zt_bnds ) 209 ! 210 # if defined key_floats 213 zt_bnds(2,: ) = gdept_1d(:) 214 zt_bnds(1,2:jpk ) = gdept_1d(1:jpkm1) 215 zt_bnds(1,1 ) = gdept_1d(1) - e3w_1d(1) 216 zw_bnds(1,: ) = gdepw_1d(:) 217 zw_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 218 zw_bnds(2,jpk: ) = gdepw_1d(jpk) + e3t_1d(jpk) 219 CALL iom_set_axis_attr( "deptht", bounds=zw_bnds ) 220 CALL iom_set_axis_attr( "depthu", bounds=zw_bnds ) 221 CALL iom_set_axis_attr( "depthv", bounds=zw_bnds ) 222 CALL iom_set_axis_attr( "depthw", bounds=zt_bnds ) 223 224 ! ABL 225 za_bnds(1,:) = ghw_abl(1:jpkam1) 226 za_bnds(2,:) = ghw_abl(2:jpka ) 227 CALL iom_set_axis_attr( "ght_abl", bounds=za_bnds ) 228 za_bnds(1,:) = ght_abl(2:jpka ) 229 za_bnds(2,:) = ght_abl(2:jpka ) + e3w_abl(2:jpka) 230 CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) 231 211 232 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 212 # endif213 233 # if defined key_si3 214 234 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) … … 217 237 # endif 218 238 #if defined key_top 219 CALL iom_set_axis_attr( "profsed", paxis = profsed )239 IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = profsed ) 220 240 #endif 221 241 CALL iom_set_axis_attr( "icbcla", class_num ) 222 CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) 223 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) 242 CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) ! strange syntaxe and idea... 243 CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) ) ! strange syntaxe and idea... 244 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) ! strange syntaxe and idea... 245 CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,5) /) ) 224 246 ENDIF 225 247 ! … … 241 263 ENDIF 242 264 ! 243 ! end file definition244 dtime%second = r dt265 ! set time step length 266 dtime%second = rn_Dt 245 267 CALL xios_set_timestep( dtime ) 268 ! 269 ! conditional closure of context definition 270 IF ( ll_closedef ) CALL iom_init_closedef 271 ! 272 DEALLOCATE( zt_bnds, zw_bnds ) 273 ! 274 #endif 275 ! 276 END SUBROUTINE iom_init 277 278 SUBROUTINE iom_init_closedef 279 !!---------------------------------------------------------------------- 280 !! *** SUBROUTINE iom_init_closedef *** 281 !!---------------------------------------------------------------------- 282 !! 283 !! ** Purpose : Closure of context definition 284 !! 285 !!---------------------------------------------------------------------- 286 287 #if defined key_iomput 246 288 CALL xios_close_context_definition() 247 289 CALL xios_update_calendar( 0 ) 248 ! 249 DEALLOCATE( zt_bnds, zw_bnds ) 250 ! 251 IF ( ll_tmppatch ) THEN 252 nldi = nldi_save ; nlei = nlei_save 253 nldj = nldj_save ; nlej = nlej_save 254 ENDIF 255 #endif 256 ! 257 END SUBROUTINE iom_init 290 #else 291 IF( .FALSE. ) WRITE(numout,*) 'iom_init_closedef: should not see this' ! useless statement to avoid compilation warnings 292 #endif 293 294 END SUBROUTINE iom_init_closedef 258 295 259 296 SUBROUTINE iom_set_rstw_var_active(field) … … 268 305 CHARACTER(LEN=256) :: clinfo ! info character 269 306 270 #if defined key_ xios307 #if defined key_iomput 271 308 llis_set = .FALSE. 272 309 … … 284 321 ENDIF 285 322 #else 286 clinfo = 'iom_set_rstw_var_active: key_ xiosis needed to use XIOS restart read/write functionality'323 clinfo = 'iom_set_rstw_var_active: key_iomput is needed to use XIOS restart read/write functionality' 287 324 CALL ctl_stop('STOP', TRIM(clinfo)) 288 325 #endif … … 301 338 CHARACTER(len=256) :: rst_file 302 339 303 #if defined key_ xios340 #if defined key_iomput 304 341 TYPE(xios_field) :: field_hdl 305 342 TYPE(xios_file) :: file_hdl … … 348 385 END SUBROUTINE iom_set_rstr_active 349 386 387 SUBROUTINE iom_set_rstw_core(cdmdl) 388 !!--------------------------------------------------------------------- 389 !! *** SUBROUTINE iom_set_rstw_core *** 390 !! 391 !! ** Purpose : set variables which are always in restart file 392 !!--------------------------------------------------------------------- 393 CHARACTER (len=*), INTENT (IN) :: cdmdl ! model OPA or SAS 394 CHARACTER(LEN=256) :: clinfo ! info character 395 #if defined key_iomput 396 IF(cdmdl == "OPA") THEN 397 !from restart.F90 398 CALL iom_set_rstw_var_active("rn_Dt") 399 IF ( .NOT. ln_diurnal_only ) THEN 400 CALL iom_set_rstw_var_active('ub' ) 401 CALL iom_set_rstw_var_active('vb' ) 402 CALL iom_set_rstw_var_active('tb' ) 403 CALL iom_set_rstw_var_active('sb' ) 404 CALL iom_set_rstw_var_active('sshb') 405 ! 406 CALL iom_set_rstw_var_active('un' ) 407 CALL iom_set_rstw_var_active('vn' ) 408 CALL iom_set_rstw_var_active('tn' ) 409 CALL iom_set_rstw_var_active('sn' ) 410 CALL iom_set_rstw_var_active('sshn') 411 CALL iom_set_rstw_var_active('rhop') 412 ENDIF 413 IF(ln_diurnal) CALL iom_set_rstw_var_active('Dsst') 414 !from trasbc.F90 415 CALL iom_set_rstw_var_active('sbc_hc_b') 416 CALL iom_set_rstw_var_active('sbc_sc_b') 417 ENDIF 418 #else 419 clinfo = 'iom_set_rstw_core: key_iomput is needed to use XIOS restart read/write functionality' 420 CALL ctl_stop('STOP', TRIM(clinfo)) 421 #endif 422 END SUBROUTINE iom_set_rstw_core 423 350 424 SUBROUTINE iom_set_rst_vars(fields) 351 425 !!--------------------------------------------------------------------- … … 360 434 361 435 i = 0 362 i = i + 1; fields(i)%vname="r dt"; fields(i)%grid="grid_scalar"436 i = i + 1; fields(i)%vname="rn_Dt"; fields(i)%grid="grid_scalar" 363 437 i = i + 1; fields(i)%vname="un"; fields(i)%grid="grid_N_3D" 364 438 i = i + 1; fields(i)%vname="ub"; fields(i)%grid="grid_N_3D" … … 476 550 !sets enabled = .TRUE. for each field in restart file 477 551 CHARACTER(len=*) :: cdrst_file 478 #if defined key_ xios552 #if defined key_iomput 479 553 TYPE(xios_field) :: field_hdl 480 554 TYPE(xios_file) :: file_hdl … … 531 605 !ld_rstr is true for restart context. There is no need to define grid for 532 606 !restart read, because it's read from file 533 #if defined key_ xios607 #if defined key_iomput 534 608 TYPE(xios_domaingroup) :: domaingroup_hdl 535 609 TYPE(xios_domain) :: domain_hdl … … 562 636 !!--------------------------------------------------------------------- 563 637 CHARACTER(len=*), INTENT(in) :: cdname 564 #if defined key_ xios638 #if defined key_iomput 565 639 TYPE(xios_context) :: nemo_hdl 566 640 … … 577 651 578 652 579 SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, lagrif, ldstop, ldiof, kdlev)653 SUBROUTINE iom_open( cdname, kiomid, ldwrt, ldstop, ldiof, kdlev, cdcomp ) 580 654 !!--------------------------------------------------------------------- 581 655 !! *** SUBROUTINE iom_open *** … … 586 660 INTEGER , INTENT( out) :: kiomid ! iom identifier of the opened file 587 661 LOGICAL , INTENT(in ), OPTIONAL :: ldwrt ! open in write modeb (default = .FALSE.) 588 INTEGER , INTENT(in ), OPTIONAL :: kdom ! Type of domain to be written (default = jpdom_local_noovlap)589 662 LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) 590 LOGICAL , INTENT(in ), OPTIONAL :: lagrif ! add 1_ prefix for AGRIF (default = .TRUE.591 663 LOGICAL , INTENT(in ), OPTIONAL :: ldiof ! Interp On the Fly, needed for AGRIF (default = .FALSE.) 592 664 INTEGER , INTENT(in ), OPTIONAL :: kdlev ! number of vertical levels 665 CHARACTER(len=3), INTENT(in ), OPTIONAL :: cdcomp ! name of component calling iom_nf90_open 593 666 ! 594 667 CHARACTER(LEN=256) :: clname ! the name of the file based on cdname [[+clcpu]+clcpu] … … 599 672 LOGICAL :: llok ! check the existence 600 673 LOGICAL :: llwrt ! local definition of ldwrt 601 LOGICAL :: llnoov ! local definition to read overlap602 674 LOGICAL :: llstop ! local definition of ldstop 603 675 LOGICAL :: lliof ! local definition of ldiof 604 LOGICAL :: llagrif ! local definition of lagrif605 676 INTEGER :: icnt ! counter for digits in clcpu (max = jpmax_digits) 606 677 INTEGER :: iln, ils ! lengths of character 607 INTEGER :: idom ! type of domain608 678 INTEGER :: istop ! 609 INTEGER, DIMENSION(2,5) :: idompar ! domain parameters:610 679 ! local number of points for x,y dimensions 611 680 ! position of first local point for x,y dimensions … … 613 682 ! start halo size for x,y dimensions 614 683 ! end halo size for x,y dimensions 615 !616 INTEGER :: nldi_save, nlei_save !:patch before we remove periodicity and close boundaries in output files617 INTEGER :: nldj_save, nlej_save !:618 !619 684 !--------------------------------------------------------------------- 620 685 ! Initializations and control … … 623 688 clinfo = ' iom_open ~~~ ' 624 689 istop = nstop 625 626 ! use patch to force the writing off periodicity and close boundaries627 ! without this, issue in some model decomposition628 ! seb: patch before we remove periodicity and close boundaries in output files629 nldi_save = nldi ; nlei_save = nlei630 nldj_save = nldj ; nlej_save = nlej631 IF( nimpp == 1 ) nldi = 1632 IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi633 IF( njmpp == 1 ) nldj = 1634 IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj635 636 690 ! if iom_open is called for the first time: initialize iom_file(:)%nfid to 0 637 691 ! (could be done when defining iom_file in f95 but not in f90) … … 650 704 ELSE ; llstop = .TRUE. 651 705 ENDIF 652 ! do we add agrif suffix653 IF( PRESENT(lagrif) ) THEN ; llagrif = lagrif654 ELSE ; llagrif = .TRUE.655 ENDIF656 706 ! are we using interpolation on the fly? 657 707 IF( PRESENT(ldiof) ) THEN ; lliof = ldiof 658 708 ELSE ; lliof = .FALSE. 659 709 ENDIF 660 ! do we read the overlap661 ! ugly patch SM+JMM+RB to overwrite global definition in some cases662 !llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif663 ! for domain_cfg, force to read the full domain664 llnoov = .FALSE.665 710 ! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix) 666 711 ! ============= 667 712 clname = trim(cdname) 668 IF ( .NOT. Agrif_Root() .AND. .NOT. lliof .AND. llagrif) THEN713 IF ( .NOT. Agrif_Root() .AND. .NOT. lliof ) THEN 669 714 iln = INDEX(clname,'/') 670 715 cltmpn = clname(1:iln) … … 702 747 lxios_sini = .TRUE. 703 748 ENDIF 704 IF( llwrt ) THEN705 ! check the domain definition706 ! JMM + SM: ugly patch before getting the new version of lib_mpp)707 ! idom = jpdom_local_noovlap ! default definition708 IF( llnoov ) THEN ; idom = jpdom_local_noovlap ! default definition709 ELSE ; idom = jpdom_local_full ! default definition710 ENDIF711 IF( PRESENT(kdom) ) idom = kdom712 ! create the domain informations713 ! =============714 SELECT CASE (idom)715 CASE (jpdom_local_full)716 idompar(:,1) = (/ jpi , jpj /)717 idompar(:,2) = (/ nimpp , njmpp /)718 idompar(:,3) = (/ nimpp + jpi - 1 , njmpp + jpj - 1 /)719 idompar(:,4) = (/ nldi - 1 , nldj - 1 /)720 idompar(:,5) = (/ jpi - nlei , jpj - nlej /)721 CASE (jpdom_local_noextra)722 idompar(:,1) = (/ nlci , nlcj /)723 idompar(:,2) = (/ nimpp , njmpp /)724 idompar(:,3) = (/ nimpp + nlci - 1, njmpp + nlcj - 1 /)725 idompar(:,4) = (/ nldi - 1 , nldj - 1 /)726 idompar(:,5) = (/ nlci - nlei , nlcj - nlej /)727 CASE (jpdom_local_noovlap)728 idompar(:,1) = (/ nlei - nldi + 1, nlej - nldj + 1 /)729 idompar(:,2) = (/ nimpp + nldi - 1, njmpp + nldj - 1 /)730 idompar(:,3) = (/ nimpp + nlei - 1, njmpp + nlej - 1 /)731 idompar(:,4) = (/ 0 , 0 /)732 idompar(:,5) = (/ 0 , 0 /)733 CASE DEFAULT734 CALL ctl_stop( TRIM(clinfo), 'wrong value of kdom, only jpdom_local* cases are accepted' )735 END SELECT736 ENDIF737 749 ! Open the NetCDF file 738 750 ! ============= … … 758 770 ENDIF 759 771 IF( istop == nstop ) THEN ! no error within this routine 760 CALL iom_nf90_open( clname, kiomid, llwrt, llok, idompar, kdlev = kdlev ) 761 ENDIF 762 763 nldi = nldi_save ; nlei = nlei_save 764 nldj = nldj_save ; nlej = nlej_save 772 CALL iom_nf90_open( clname, kiomid, llwrt, llok, kdlev = kdlev, cdcomp = cdcomp ) 773 ENDIF 765 774 ! 766 775 END SUBROUTINE iom_open … … 781 790 CHARACTER(LEN=100) :: clinfo ! info character 782 791 !--------------------------------------------------------------------- 792 ! 793 IF( iom_open_init == 0 ) RETURN ! avoid to use iom_file(jf)%nfid that us not yet initialized 783 794 ! 784 795 clinfo = ' iom_close ~~~ ' … … 808 819 809 820 810 FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, ld stop )821 FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, lduld, ldstop ) 811 822 !!----------------------------------------------------------------------- 812 823 !! *** FUNCTION iom_varid *** … … 817 828 CHARACTER(len=*) , INTENT(in ) :: cdvar ! name of the variable 818 829 INTEGER, DIMENSION(:), INTENT( out), OPTIONAL :: kdimsz ! size of each dimension 819 INTEGER, INTENT( out), OPTIONAL :: kndims ! size of the dimensions 830 INTEGER , INTENT( out), OPTIONAL :: kndims ! number of dimensions 831 LOGICAL , INTENT( out), OPTIONAL :: lduld ! true if the last dimension is unlimited (time) 820 832 LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if looking for non-existing variable (default = .TRUE.) 821 833 ! … … 847 859 iiv = iiv + 1 848 860 IF( iiv <= jpmax_vars ) THEN 849 iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims )861 iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims, lduld ) 850 862 ELSE 851 863 CALL ctl_stop( trim(clinfo), 'Too many variables in the file '//iom_file(kiomid)%name, & … … 865 877 ENDIF 866 878 IF( PRESENT(kndims) ) kndims = iom_file(kiomid)%ndims(iiv) 879 IF( PRESENT( lduld) ) lduld = iom_file(kiomid)%luld( iiv) 867 880 ENDIF 868 881 ENDIF … … 875 888 !! INTERFACE iom_get 876 889 !!---------------------------------------------------------------------- 877 SUBROUTINE iom_g0d ( kiomid, cdvar, pvar, ktime, ldxios )890 SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime, ldxios ) 878 891 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 879 892 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 880 REAL(wp) , INTENT( out) :: pvar ! read field 893 REAL(sp) , INTENT( out) :: pvar ! read field 894 REAL(dp) :: ztmp_pvar ! tmp var to read field 895 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 896 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart 897 ! 898 INTEGER :: idvar ! variable id 899 INTEGER :: idmspc ! number of spatial dimensions 900 INTEGER , DIMENSION(1) :: itime ! record number 901 CHARACTER(LEN=100) :: clinfo ! info character 902 CHARACTER(LEN=100) :: clname ! file name 903 CHARACTER(LEN=1) :: cldmspc ! 904 LOGICAL :: llxios 905 ! 906 llxios = .FALSE. 907 IF( PRESENT(ldxios) ) llxios = ldxios 908 909 IF(.NOT.llxios) THEN ! read data using default library 910 itime = 1 911 IF( PRESENT(ktime) ) itime = ktime 912 ! 913 clname = iom_file(kiomid)%name 914 clinfo = ' iom_g0d, file: '//trim(clname)//', var: '//trim(cdvar) 915 ! 916 IF( kiomid > 0 ) THEN 917 idvar = iom_varid( kiomid, cdvar ) 918 IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN 919 idmspc = iom_file ( kiomid )%ndims( idvar ) 920 IF( iom_file(kiomid)%luld(idvar) ) idmspc = idmspc - 1 921 WRITE(cldmspc , fmt='(i1)') idmspc 922 IF( idmspc > 0 ) CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', & 923 & 'with 1 or more spatial dimensions: '//cldmspc//' were found.' , & 924 & 'Use ncwa -a to suppress the unnecessary dimensions' ) 925 CALL iom_nf90_get( kiomid, idvar, ztmp_pvar, itime ) 926 pvar = ztmp_pvar 927 ENDIF 928 ENDIF 929 ELSE 930 #if defined key_iomput 931 IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 932 CALL iom_swap( TRIM(crxios_context) ) 933 CALL xios_recv_field( trim(cdvar), pvar) 934 CALL iom_swap( TRIM(cxios_context) ) 935 #else 936 WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) 937 CALL ctl_stop( 'iom_g0d', ctmp1 ) 938 #endif 939 ENDIF 940 END SUBROUTINE iom_g0d_sp 941 942 SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime, ldxios ) 943 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 944 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 945 REAL(dp) , INTENT( out) :: pvar ! read field 881 946 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 882 947 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart … … 913 978 ENDIF 914 979 ELSE 915 #if defined key_ xios980 #if defined key_iomput 916 981 IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 917 982 CALL iom_swap( TRIM(crxios_context) ) … … 923 988 #endif 924 989 ENDIF 925 END SUBROUTINE iom_g0d 926 927 SUBROUTINE iom_g1d ( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios )990 END SUBROUTINE iom_g0d_dp 991 992 SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 928 993 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 929 994 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 930 995 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 931 REAL(wp) , INTENT( out), DIMENSION(:) :: pvar ! read field 996 REAL(sp) , INTENT( out), DIMENSION(:) :: pvar ! read field 997 REAL(dp) , ALLOCATABLE , DIMENSION(:) :: ztmp_pvar ! tmp var to read field 932 998 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 933 999 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading … … 936 1002 ! 937 1003 IF( kiomid > 0 ) THEN 1004 IF( iom_file(kiomid)%nfid > 0 ) THEN 1005 ALLOCATE(ztmp_pvar(size(pvar,1))) 1006 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=ztmp_pvar, & 1007 & ktime=ktime, kstart=kstart, kcount=kcount, & 1008 & ldxios=ldxios ) 1009 pvar = ztmp_pvar 1010 DEALLOCATE(ztmp_pvar) 1011 END IF 1012 ENDIF 1013 END SUBROUTINE iom_g1d_sp 1014 1015 1016 SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 1017 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1018 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1019 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1020 REAL(dp) , INTENT( out), DIMENSION(:) :: pvar ! read field 1021 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1022 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading 1023 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis 1024 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1025 ! 1026 IF( kiomid > 0 ) THEN 938 1027 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & 939 1028 & ktime=ktime, kstart=kstart, kcount=kcount, & 940 1029 & ldxios=ldxios ) 941 1030 ENDIF 942 END SUBROUTINE iom_g1d 943 944 SUBROUTINE iom_g2d ( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios)945 INTEGER , INTENT(in ) 946 INTEGER , INTENT(in ) 947 CHARACTER(len=*), INTENT(in ) 948 REAL( wp) , INTENT( out), DIMENSION(:,:):: pvar ! read field949 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number950 INTEGER , INTENT(in ) , DIMENSION(2) , OPTIONAL :: kstart ! start axis position of the reading951 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kcount ! number of points in each axis952 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to953 ! look for and use a file attribute954 ! called open_ocean_jstart to set the start955 ! value for the 2nd dimension (netcdf only)956 LOGICAL , INTENT(in ), OPTIONAL :: ldxios 1031 END SUBROUTINE iom_g1d_dp 1032 1033 SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios) 1034 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1035 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1036 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1037 REAL(sp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1038 REAL(dp) , ALLOCATABLE , DIMENSION(:,:) :: ztmp_pvar ! tmp var to read field 1039 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1040 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1041 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold 1042 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1043 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading 1044 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis 1045 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 957 1046 ! 958 1047 IF( kiomid > 0 ) THEN 959 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=pvar, & 960 & ktime=ktime, kstart=kstart, kcount=kcount, & 961 & lrowattr=lrowattr, ldxios=ldxios) 962 ENDIF 963 END SUBROUTINE iom_g2d 964 965 SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios ) 966 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 967 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 968 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 969 REAL(wp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 970 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 971 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kstart ! start axis position of the reading 972 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kcount ! number of points in each axis 973 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 974 ! look for and use a file attribute 975 ! called open_ocean_jstart to set the start 976 ! value for the 2nd dimension (netcdf only) 977 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1048 IF( iom_file(kiomid)%nfid > 0 ) THEN 1049 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2))) 1050 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = ztmp_pvar , ktime = ktime, & 1051 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1052 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1053 pvar = ztmp_pvar 1054 DEALLOCATE(ztmp_pvar) 1055 ENDIF 1056 ENDIF 1057 END SUBROUTINE iom_g2d_sp 1058 1059 SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios) 1060 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1061 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1062 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1063 REAL(dp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1064 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1065 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1066 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold 1067 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1068 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading 1069 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis 1070 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 978 1071 ! 979 1072 IF( kiomid > 0 ) THEN 980 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=pvar, & 981 & ktime=ktime, kstart=kstart, kcount=kcount, & 982 & lrowattr=lrowattr, ldxios=ldxios ) 983 ENDIF 984 END SUBROUTINE iom_g3d 1073 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = pvar , ktime = ktime, & 1074 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1075 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1076 ENDIF 1077 END SUBROUTINE iom_g2d_dp 1078 1079 SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios ) 1080 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1081 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1082 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1083 REAL(sp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1084 REAL(dp) , ALLOCATABLE , DIMENSION(:,:,:) :: ztmp_pvar ! tmp var to read field 1085 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1086 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1087 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold 1088 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1089 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading 1090 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis 1091 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1092 ! 1093 IF( kiomid > 0 ) THEN 1094 IF( iom_file(kiomid)%nfid > 0 ) THEN 1095 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3))) 1096 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = ztmp_pvar , ktime = ktime, & 1097 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1098 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1099 pvar = ztmp_pvar 1100 DEALLOCATE(ztmp_pvar) 1101 END IF 1102 ENDIF 1103 END SUBROUTINE iom_g3d_sp 1104 1105 SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios ) 1106 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1107 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1108 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1109 REAL(dp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1110 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1111 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1112 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold 1113 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1114 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading 1115 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis 1116 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1117 ! 1118 IF( kiomid > 0 ) THEN 1119 IF( iom_file(kiomid)%nfid > 0 ) THEN 1120 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = pvar , ktime = ktime, & 1121 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1122 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1123 END IF 1124 ENDIF 1125 END SUBROUTINE iom_g3d_dp 1126 985 1127 !!---------------------------------------------------------------------- 986 1128 987 SUBROUTINE iom_get_123d( kiomid, kdom , cdvar , & 988 & pv_r1d, pv_r2d, pv_r3d, & 989 & ktime , kstart, kcount, & 990 & lrowattr, ldxios ) 1129 SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , & 1130 & cd_type, psgn, kfill, kstart, kcount, ldxios ) 991 1131 !!----------------------------------------------------------------------- 992 1132 !! *** ROUTINE iom_get_123d *** … … 996 1136 !! ** Method : read ONE record at each CALL 997 1137 !!----------------------------------------------------------------------- 998 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 999 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1000 CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable 1001 REAL(wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 1002 REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 1003 REAL(wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 1004 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 1005 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 1006 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 1007 LOGICAL , INTENT(in ), OPTIONAL :: lrowattr ! logical flag telling iom_get to 1008 ! look for and use a file attribute 1009 ! called open_ocean_jstart to set the start 1010 ! value for the 2nd dimension (netcdf only) 1011 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use XIOS to read restart 1012 ! 1013 LOGICAL :: llxios ! local definition for XIOS read 1014 LOGICAL :: llnoov ! local definition to read overlap 1015 LOGICAL :: luse_jattr ! local definition to read open_ocean_jstart file attribute 1016 INTEGER :: jstartrow ! start point for 2nd dimension optionally set by file attribute 1138 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1139 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1140 CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable 1141 REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 1142 REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 1143 REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 1144 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 1145 CHARACTER(len=1) , INTENT(in ), OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1146 REAL(dp) , INTENT(in ), OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold 1147 INTEGER , INTENT(in ), OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1148 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 1149 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 1150 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use XIOS to read restart 1151 ! 1152 LOGICAL :: llok ! true if ok! 1153 LOGICAL :: llxios ! local definition for XIOS read 1017 1154 INTEGER :: jl ! loop on number of dimension 1018 1155 INTEGER :: idom ! type of domain … … 1030 1167 INTEGER, DIMENSION(jpmax_dims) :: idimsz ! size of the dimensions of the variable 1031 1168 INTEGER, DIMENSION(jpmax_dims) :: ishape ! size of the dimensions of the variable 1032 REAL(wp) :: zscf, zofs ! sacle_factor and add_offset 1169 REAL(dp) :: zscf, zofs ! sacle_factor and add_offset 1170 REAL(wp) :: zsgn ! local value of psgn 1033 1171 INTEGER :: itmp ! temporary integer 1034 1172 CHARACTER(LEN=256) :: clinfo ! info character 1035 1173 CHARACTER(LEN=256) :: clname ! file name 1036 1174 CHARACTER(LEN=1) :: clrankpv, cldmspc ! 1037 LOGICAL :: ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 1175 CHARACTER(LEN=1) :: cl_type ! local value of cd_type 1176 LOGICAL :: ll_only3rd ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 1038 1177 INTEGER :: inlev ! number of levels for 3D data 1039 REAL( wp) :: gma, gmi1178 REAL(dp) :: gma, gmi 1040 1179 !--------------------------------------------------------------------- 1041 1180 ! … … 1044 1183 ! 1045 1184 llxios = .FALSE. 1046 if(PRESENT(ldxios))llxios = ldxios1047 idvar = iom_varid( kiomid, cdvar )1185 IF( PRESENT(ldxios) ) llxios = ldxios 1186 ! 1048 1187 idom = kdom 1188 istop = nstop 1049 1189 ! 1050 1190 IF(.NOT.llxios) THEN 1051 1191 clname = iom_file(kiomid)%name ! esier to read 1052 1192 clinfo = ' iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) 1053 ! local definition of the domain ?1054 ! do we read the overlap1055 ! ugly patch SM+JMM+RB to overwrite global definition in some cases1056 !1057 !llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif1058 ! for domain_cfg tools force to read the full domain1059 llnoov = .FALSE.1060 1193 ! check kcount and kstart optionals parameters... 1061 IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present') 1062 IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 1063 IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND. idom /= jpdom_autoglo_xy ) & 1064 & CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown or kdom = jpdom_autoglo_xy') 1065 1066 luse_jattr = .false. 1067 IF( PRESENT(lrowattr) ) THEN 1068 IF( lrowattr .AND. idom /= jpdom_data ) CALL ctl_stop(trim(clinfo), 'lrowattr present and true needs kdom = jpdom_data') 1069 IF( lrowattr .AND. idom == jpdom_data ) luse_jattr = .true. 1070 ENDIF 1071 1194 IF( PRESENT(kcount) .AND. .NOT. PRESENT(kstart) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present') 1195 IF( PRESENT(kstart) .AND. .NOT. PRESENT(kcount) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 1196 IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND. idom /= jpdom_auto_xy ) & 1197 & CALL ctl_stop(TRIM(clinfo), 'kstart present needs idom = jpdom_unknown or idom = jpdom_auto_xy') 1198 IF( idom == jpdom_auto_xy .AND. .NOT. PRESENT(kstart) ) & 1199 & CALL ctl_stop(TRIM(clinfo), 'idom = jpdom_auto_xy requires kstart to be present') 1200 ! 1072 1201 ! Search for the variable in the data base (eventually actualize data) 1073 istop = nstop1074 1202 ! 1203 idvar = iom_varid( kiomid, cdvar ) 1075 1204 IF( idvar > 0 ) THEN 1076 ! to write iom_file(kiomid)%dimsz in a shorter way !1077 idimsz(:) = iom_file(kiomid)%dimsz(:, idvar) 1205 ! 1206 idimsz(:) = iom_file(kiomid)%dimsz(:, idvar) ! to write iom_file(kiomid)%dimsz in a shorter way 1078 1207 inbdim = iom_file(kiomid)%ndims(idvar) ! number of dimensions in the file 1079 1208 idmspc = inbdim ! number of spatial dimensions in the file … … 1081 1210 IF( idmspc > 3 ) CALL ctl_stop(trim(clinfo), 'the file has more than 3 spatial dimensions this case is not coded...') 1082 1211 ! 1083 ! update idom definition... 1084 ! Identify the domain in case of jpdom_auto(glo/dta) definition 1085 IF( idom == jpdom_autoglo_xy ) THEN 1086 ll_depth_spec = .TRUE. 1087 idom = jpdom_autoglo 1088 ELSE 1089 ll_depth_spec = .FALSE. 1090 ENDIF 1091 IF( idom == jpdom_autoglo .OR. idom == jpdom_autodta ) THEN 1092 IF( idom == jpdom_autoglo ) THEN ; idom = jpdom_global 1093 ELSE ; idom = jpdom_data 1094 ENDIF 1212 ! Identify the domain in case of jpdom_auto definition 1213 IF( idom == jpdom_auto .OR. idom == jpdom_auto_xy ) THEN 1214 idom = jpdom_global ! default 1215 ! else: if the file name finishes with _xxxx.nc with xxxx any number 1095 1216 ind1 = INDEX( clname, '_', back = .TRUE. ) + 1 1096 1217 ind2 = INDEX( clname, '.', back = .TRUE. ) - 1 1097 1218 IF( ind2 > ind1 ) THEN ; IF( VERIFY( clname(ind1:ind2), '0123456789' ) == 0 ) idom = jpdom_local ; ENDIF 1098 ENDIF1099 ! Identify the domain in case of jpdom_local definition1100 IF( idom == jpdom_local ) THEN1101 IF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN ; idom = jpdom_local_full1102 ELSEIF( idimsz(1) == nlci .AND. idimsz(2) == nlcj ) THEN ; idom = jpdom_local_noextra1103 ELSEIF( idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1) ) THEN ; idom = jpdom_local_noovlap1104 ELSE ; CALL ctl_stop( trim(clinfo), 'impossible to identify the local domain' )1105 ENDIF1106 1219 ENDIF 1107 1220 ! … … 1116 1229 WRITE(cldmspc , fmt='(i1)') idmspc 1117 1230 ! 1118 IF( idmspc < irankpv ) THEN 1119 CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension', & 1120 & 'it is impossible to read a '//clrankpv//'D array from this file...' ) 1231 IF( idmspc < irankpv ) THEN ! it seems we want to read more than we can... 1232 IF( irankpv == 3 .AND. idmspc == 2 ) THEN ! 3D input array from 2D spatial data in the file: 1233 llok = inlev == 1 ! -> 3rd dimension must be equal to 1 1234 ELSEIF( irankpv == 3 .AND. idmspc == 1 ) THEN ! 3D input array from 1D spatial data in the file: 1235 llok = inlev == 1 .AND. SIZE(pv_r3d, 2) == 1 ! -> 2nd and 3rd dimensions must be equal to 1 1236 ELSEIF( irankpv == 2 .AND. idmspc == 2 ) THEN ! 2D input array from 1D spatial data in the file: 1237 llok = SIZE(pv_r2d, 2) == 1 ! -> 2nd dimension must be equal to 1 1238 ELSE 1239 llok = .FALSE. 1240 ENDIF 1241 IF( .NOT. llok ) CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension', & 1242 & '=> cannot read a true '//clrankpv//'D array from this file...' ) 1121 1243 ELSEIF( idmspc == irankpv ) THEN 1122 1244 IF( PRESENT(pv_r1d) .AND. idom /= jpdom_unknown ) & 1123 1245 & CALL ctl_stop( TRIM(clinfo), 'case not coded...You must use jpdom_unknown' ) 1124 ELSEIF( idmspc > irankpv ) THEN 1246 ELSEIF( idmspc > irankpv ) THEN ! it seems we want to read less than we should... 1125 1247 IF( PRESENT(pv_r2d) .AND. itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN 1126 CALL ctl_warn( trim(clinfo), '2D array but 3 spatial dimensions for the data...' , &1248 CALL ctl_warn( trim(clinfo), '2D array input but 3 spatial dimensions in the file...' , & 1127 1249 & 'As the size of the z dimension is 1 and as we try to read the first record, ', & 1128 1250 & 'we accept this case, even if there is a possible mix-up between z and time dimension' ) 1129 1251 idmspc = idmspc - 1 1130 ELSE 1131 CALL ctl_stop( TRIM(clinfo), 'To keep iom lisibility, when reading a '//clrankpv//'D array,' , & 1132 & 'we do not accept data with '//cldmspc//' spatial dimensions', & 1133 & 'Use ncwa -a to suppress the unnecessary dimensions' ) 1252 !!GS: possibility to read 3D ABL atmopsheric forcing and use 1st level to force BULK simulation 1253 !ELSE 1254 ! CALL ctl_stop( TRIM(clinfo), 'To keep iom lisibility, when reading a '//clrankpv//'D array,', & 1255 ! & 'we do not accept data with '//cldmspc//' spatial dimensions' , & 1256 ! & 'Use ncwa -a to suppress the unnecessary dimensions' ) 1134 1257 ENDIF 1135 1258 ENDIF … … 1137 1260 ! definition of istart and icnt 1138 1261 ! 1139 icnt (:) = 1 1140 istart(:) = 1 1141 istart(idmspc+1) = itime 1142 1143 IF( PRESENT(kstart) .AND. .NOT. ll_depth_spec ) THEN 1144 istart(1:idmspc) = kstart(1:idmspc) 1145 icnt (1:idmspc) = kcount(1:idmspc) 1146 ELSE 1147 IF(idom == jpdom_unknown ) THEN 1148 icnt(1:idmspc) = idimsz(1:idmspc) 1149 ELSE 1150 IF( .NOT. PRESENT(pv_r1d) ) THEN ! not a 1D array 1151 IF( idom == jpdom_data ) THEN 1152 jstartrow = 1 1153 IF( luse_jattr ) THEN 1154 CALL iom_getatt(kiomid, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found 1155 jstartrow = MAX(1,jstartrow) 1156 ENDIF 1157 istart(1:2) = (/ mig(1), mjg(1) + jstartrow - 1 /) ! icnt(1:2) done below 1158 ELSEIF( idom == jpdom_global ) THEN ; istart(1:2) = (/ nimpp , njmpp /) ! icnt(1:2) done below 1159 ENDIF 1160 ! we do not read the overlap -> we start to read at nldi, nldj 1161 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1162 ! IF( idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) 1163 IF( llnoov .AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) 1164 ! we do not read the overlap and the extra-halos -> from nldi to nlei and from nldj to nlej 1165 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1166 ! icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) 1167 IF( llnoov ) THEN ; icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) 1168 ELSE ; icnt(1:2) = (/ nlci , nlcj /) 1169 ENDIF 1170 IF( PRESENT(pv_r3d) ) THEN 1171 IF( idom == jpdom_data ) THEN ; icnt(3) = inlev 1172 ELSEIF( ll_depth_spec .AND. PRESENT(kstart) ) THEN ; istart(3) = kstart(3) ; icnt(3) = kcount(3) 1173 ELSE ; icnt(3) = inlev 1174 ENDIF 1175 ENDIF 1262 icnt (:) = 1 ! default definition (simple way to deal with special cases listed above) 1263 istart(:) = 1 ! default definition (simple way to deal with special cases listed above) 1264 istart(idmspc+1) = itime ! temporal dimenstion 1265 ! 1266 IF( idom == jpdom_unknown ) THEN 1267 IF( PRESENT(kstart) .AND. idom /= jpdom_auto_xy ) THEN 1268 istart(1:idmspc) = kstart(1:idmspc) 1269 icnt (1:idmspc) = kcount(1:idmspc) 1270 ELSE 1271 icnt (1:idmspc) = idimsz(1:idmspc) 1272 ENDIF 1273 ELSE ! not a 1D array as pv_r1d requires jpdom_unknown 1274 ! we do not read the overlap and the extra-halos -> from Nis0 to Nie0 and from Njs0 to Nje0 1275 IF( idom == jpdom_global ) istart(1:2) = (/ mig0(Nis0), mjg0(Njs0) /) 1276 icnt(1:2) = (/ Ni_0, Nj_0 /) 1277 IF( PRESENT(pv_r3d) ) THEN 1278 IF( idom == jpdom_auto_xy ) THEN 1279 istart(3) = kstart(3) 1280 icnt (3) = kcount(3) 1281 ELSE 1282 icnt (3) = inlev 1176 1283 ENDIF 1177 1284 ENDIF 1178 1285 ENDIF 1179 1286 ! 1180 1287 ! check that istart and icnt can be used with this file 1181 1288 !- … … 1188 1295 ENDIF 1189 1296 END DO 1190 1297 ! 1191 1298 ! check that icnt matches the input array 1192 1299 !- … … 1198 1305 ELSE 1199 1306 IF( irankpv == 2 ) THEN 1200 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1201 ! ishape(1:2) = SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1 = 'd(nldi:nlei,nldj:nlej)' 1202 IF( llnoov ) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1='d(nldi:nlei,nldj:nlej)' 1203 ELSE ; ishape(1:2)=SHAPE(pv_r2d(1 :nlci,1 :nlcj )) ; ctmp1='d(1:nlci,1:nlcj)' 1204 ENDIF 1307 ishape(1:2) = SHAPE(pv_r2d(Nis0:Nie0,Njs0:Nje0 )) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0)' 1205 1308 ENDIF 1206 1309 IF( irankpv == 3 ) THEN 1207 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1208 ! ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1 = 'd(nldi:nlei,nldj:nlej,:)' 1209 IF( llnoov ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)' 1210 ELSE ; ishape(1:3)=SHAPE(pv_r3d(1 :nlci,1 :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)' 1211 ENDIF 1310 ishape(1:3) = SHAPE(pv_r3d(Nis0:Nie0,Njs0:Nje0,:)) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0,:)' 1212 1311 ENDIF 1213 ENDIF 1214 1312 ENDIF 1215 1313 DO jl = 1, irankpv 1216 1314 WRITE( ctmp2, FMT="(', ', i1,'): ', i5,' /= icnt(', i1,'):', i5)" ) jl, ishape(jl), jl, icnt(jl) … … 1224 1322 IF( idvar > 0 .AND. istop == nstop ) THEN ! no additional errors until this point... 1225 1323 ! 1226 ! find the right index of the array to be read 1227 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 1228 ! IF( idom /= jpdom_unknown ) THEN ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej 1229 ! ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 1230 ! ENDIF 1231 IF( llnoov ) THEN 1232 IF( idom /= jpdom_unknown ) THEN ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej 1233 ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 1234 ENDIF 1235 ELSE 1236 IF( idom /= jpdom_unknown ) THEN ; ix1 = 1 ; ix2 = nlci ; iy1 = 1 ; iy2 = nlcj 1237 ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 1238 ENDIF 1324 ! find the right index of the array to be read 1325 IF( idom /= jpdom_unknown ) THEN ; ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0 1326 ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 1239 1327 ENDIF 1240 1328 1241 1329 CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, pv_r3d ) 1242 1330 1243 1331 IF( istop == nstop ) THEN ! no additional errors until this point... 1244 1332 IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i6,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name) 1245 1333 1334 cl_type = 'T' 1335 IF( PRESENT(cd_type) ) cl_type = cd_type 1336 zsgn = 1._wp 1337 IF( PRESENT(psgn ) ) zsgn = psgn 1246 1338 !--- overlap areas and extra hallows (mpp) 1247 IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 1248 CALL lbc_lnk( 'iom', pv_r2d,'Z',-999.,'no0' ) 1249 ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN 1250 ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 1251 IF( icnt(3) == inlev ) THEN 1252 CALL lbc_lnk( 'iom', pv_r3d,'Z',-999.,'no0' ) 1253 ELSE ! put some arbitrary value (a call to lbc_lnk will be done later...) 1254 DO jj = nlcj+1, jpj ; pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :) ; END DO 1255 DO ji = nlci+1, jpi ; pv_r3d(ji , : , :) = pv_r3d(nlei , : , :) ; END DO 1256 ENDIF 1339 IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN 1340 CALL lbc_lnk( 'iom', pv_r2d, cl_type, zsgn, kfillmode = kfill ) 1341 ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN 1342 CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill ) 1257 1343 ENDIF 1258 1344 ! … … 1267 1353 ! 1268 1354 ELSE ! read using XIOS. Only if KEY_IOMPUT is defined 1269 #if defined key_ xios1355 #if defined key_iomput 1270 1356 !would be good to be able to check which context is active and swap only if current is not restart 1271 1357 CALL iom_swap( TRIM(crxios_context) ) 1272 1358 IF( PRESENT(pv_r3d) ) THEN 1273 pv_r3d(:, :, :) = 0. 1274 if(lwp) write(numout,*) 'XIOS RST READ (3D): ',trim(cdvar) 1359 IF(lwp) WRITE(numout,*) 'XIOS RST READ (3D): ',TRIM(cdvar) 1275 1360 CALL xios_recv_field( trim(cdvar), pv_r3d) 1276 IF(idom /= jpdom_unknown ) then 1277 CALL lbc_lnk( 'iom', pv_r3d,'Z',-999.,'no0' ) 1278 ENDIF 1361 IF(idom /= jpdom_unknown ) CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) 1279 1362 ELSEIF( PRESENT(pv_r2d) ) THEN 1280 pv_r2d(:, :) = 0. 1281 if(lwp) write(numout,*) 'XIOS RST READ (2D): ', trim(cdvar) 1363 IF(lwp) WRITE(numout,*) 'XIOS RST READ (2D): ', TRIM(cdvar) 1282 1364 CALL xios_recv_field( trim(cdvar), pv_r2d) 1283 IF(idom /= jpdom_unknown ) THEN 1284 CALL lbc_lnk('iom', pv_r2d,'Z',-999.,'no0') 1285 ENDIF 1365 IF(idom /= jpdom_unknown ) CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) 1286 1366 ELSEIF( PRESENT(pv_r1d) ) THEN 1287 pv_r1d(:) = 0. 1288 if(lwp) write(numout,*) 'XIOS RST READ (1D): ', trim(cdvar) 1367 IF(lwp) WRITE(numout,*) 'XIOS RST READ (1D): ', TRIM(cdvar) 1289 1368 CALL xios_recv_field( trim(cdvar), pv_r1d) 1290 1369 ENDIF … … 1297 1376 !some final adjustments 1298 1377 ! C1D case : always call lbc_lnk to replicate the central value over the whole 3X3 domain 1378 ! IF( lk_c1d .AND. PRESENT(pv_r2d) ) CALL lbc_lnk( 'iom', pv_r2d,'Z',1.0_wp ) 1379 ! IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1.0_wp ) 1299 1380 1300 1381 !--- Apply scale_factor and offset … … 1314 1395 END SUBROUTINE iom_get_123d 1315 1396 1397 SUBROUTINE iom_get_var( cdname, z2d) 1398 CHARACTER(LEN=*), INTENT(in ) :: cdname 1399 REAL(wp), DIMENSION(jpi,jpj) :: z2d 1400 #if defined key_iomput 1401 IF( xios_field_is_active( cdname, at_current_timestep_arg = .TRUE. ) ) THEN 1402 z2d(:,:) = 0._wp 1403 CALL xios_recv_field( cdname, z2d) 1404 ENDIF 1405 #else 1406 IF( .FALSE. ) WRITE(numout,*) cdname, z2d ! useless test to avoid compilation warnings 1407 #endif 1408 END SUBROUTINE iom_get_var 1409 1316 1410 1317 1411 FUNCTION iom_getszuld ( kiomid ) … … 1470 1564 !! INTERFACE iom_rstput 1471 1565 !!---------------------------------------------------------------------- 1472 SUBROUTINE iom_rp0d ( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1566 SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1473 1567 INTEGER , INTENT(in) :: kt ! ocean time-step 1474 1568 INTEGER , INTENT(in) :: kwrite ! writing time-step 1475 1569 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1476 1570 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1477 REAL( wp) , INTENT(in) :: pvar ! written field1571 REAL(sp) , INTENT(in) :: pvar ! written field 1478 1572 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1479 1573 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1484 1578 IF(PRESENT(ldxios)) llx = ldxios 1485 1579 IF( llx ) THEN 1486 #ifdef key_xios 1580 #ifdef key_iomput 1581 IF( kt == kwrite ) THEN 1582 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1583 CALL xios_send_field(trim(cdvar), pvar) 1584 ENDIF 1585 #endif 1586 ELSE 1587 IF( kiomid > 0 ) THEN 1588 IF( iom_file(kiomid)%nfid > 0 ) THEN 1589 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1590 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = real(pvar, dp) ) 1591 ENDIF 1592 ENDIF 1593 ENDIF 1594 END SUBROUTINE iom_rp0d_sp 1595 1596 SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1597 INTEGER , INTENT(in) :: kt ! ocean time-step 1598 INTEGER , INTENT(in) :: kwrite ! writing time-step 1599 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1600 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1601 REAL(dp) , INTENT(in) :: pvar ! written field 1602 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1603 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1604 LOGICAL :: llx ! local xios write flag 1605 INTEGER :: ivid ! variable id 1606 1607 llx = .FALSE. 1608 IF(PRESENT(ldxios)) llx = ldxios 1609 IF( llx ) THEN 1610 #ifdef key_iomput 1487 1611 IF( kt == kwrite ) THEN 1488 1612 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) … … 1498 1622 ENDIF 1499 1623 ENDIF 1500 END SUBROUTINE iom_rp0d 1501 1502 SUBROUTINE iom_rp1d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1624 END SUBROUTINE iom_rp0d_dp 1625 1626 1627 SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1503 1628 INTEGER , INTENT(in) :: kt ! ocean time-step 1504 1629 INTEGER , INTENT(in) :: kwrite ! writing time-step 1505 1630 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1506 1631 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1507 REAL( wp) , INTENT(in), DIMENSION( :) :: pvar ! written field1632 REAL(sp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1508 1633 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1509 1634 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1514 1639 IF(PRESENT(ldxios)) llx = ldxios 1515 1640 IF( llx ) THEN 1516 #ifdef key_xios 1641 #ifdef key_iomput 1642 IF( kt == kwrite ) THEN 1643 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1644 CALL xios_send_field(trim(cdvar), pvar) 1645 ENDIF 1646 #endif 1647 ELSE 1648 IF( kiomid > 0 ) THEN 1649 IF( iom_file(kiomid)%nfid > 0 ) THEN 1650 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1651 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = real(pvar, dp) ) 1652 ENDIF 1653 ENDIF 1654 ENDIF 1655 END SUBROUTINE iom_rp1d_sp 1656 1657 SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1658 INTEGER , INTENT(in) :: kt ! ocean time-step 1659 INTEGER , INTENT(in) :: kwrite ! writing time-step 1660 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1661 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1662 REAL(dp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1663 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1664 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1665 LOGICAL :: llx ! local xios write flag 1666 INTEGER :: ivid ! variable id 1667 1668 llx = .FALSE. 1669 IF(PRESENT(ldxios)) llx = ldxios 1670 IF( llx ) THEN 1671 #ifdef key_iomput 1517 1672 IF( kt == kwrite ) THEN 1518 1673 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) … … 1528 1683 ENDIF 1529 1684 ENDIF 1530 END SUBROUTINE iom_rp1d 1531 1532 SUBROUTINE iom_rp2d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1685 END SUBROUTINE iom_rp1d_dp 1686 1687 1688 SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1533 1689 INTEGER , INTENT(in) :: kt ! ocean time-step 1534 1690 INTEGER , INTENT(in) :: kwrite ! writing time-step 1535 1691 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1536 1692 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1537 REAL( wp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field1693 REAL(sp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1538 1694 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1539 1695 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1544 1700 IF(PRESENT(ldxios)) llx = ldxios 1545 1701 IF( llx ) THEN 1546 #ifdef key_xios 1702 #ifdef key_iomput 1703 IF( kt == kwrite ) THEN 1704 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1705 CALL xios_send_field(trim(cdvar), pvar) 1706 ENDIF 1707 #endif 1708 ELSE 1709 IF( kiomid > 0 ) THEN 1710 IF( iom_file(kiomid)%nfid > 0 ) THEN 1711 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1712 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = real(pvar, dp) ) 1713 ENDIF 1714 ENDIF 1715 ENDIF 1716 END SUBROUTINE iom_rp2d_sp 1717 1718 SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1719 INTEGER , INTENT(in) :: kt ! ocean time-step 1720 INTEGER , INTENT(in) :: kwrite ! writing time-step 1721 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1722 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1723 REAL(dp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1724 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1725 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1726 LOGICAL :: llx 1727 INTEGER :: ivid ! variable id 1728 1729 llx = .FALSE. 1730 IF(PRESENT(ldxios)) llx = ldxios 1731 IF( llx ) THEN 1732 #ifdef key_iomput 1547 1733 IF( kt == kwrite ) THEN 1548 1734 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) … … 1558 1744 ENDIF 1559 1745 ENDIF 1560 END SUBROUTINE iom_rp2d 1561 1562 SUBROUTINE iom_rp3d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1746 END SUBROUTINE iom_rp2d_dp 1747 1748 1749 SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1563 1750 INTEGER , INTENT(in) :: kt ! ocean time-step 1564 1751 INTEGER , INTENT(in) :: kwrite ! writing time-step 1565 1752 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1566 1753 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1567 REAL( wp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field1754 REAL(sp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1568 1755 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1569 1756 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1574 1761 IF(PRESENT(ldxios)) llx = ldxios 1575 1762 IF( llx ) THEN 1576 #ifdef key_xios 1763 #ifdef key_iomput 1764 IF( kt == kwrite ) THEN 1765 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1766 CALL xios_send_field(trim(cdvar), pvar) 1767 ENDIF 1768 #endif 1769 ELSE 1770 IF( kiomid > 0 ) THEN 1771 IF( iom_file(kiomid)%nfid > 0 ) THEN 1772 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1773 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = real(pvar, dp) ) 1774 ENDIF 1775 ENDIF 1776 ENDIF 1777 END SUBROUTINE iom_rp3d_sp 1778 1779 SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1780 INTEGER , INTENT(in) :: kt ! ocean time-step 1781 INTEGER , INTENT(in) :: kwrite ! writing time-step 1782 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1783 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1784 REAL(dp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1785 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1786 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1787 LOGICAL :: llx ! local xios write flag 1788 INTEGER :: ivid ! variable id 1789 1790 llx = .FALSE. 1791 IF(PRESENT(ldxios)) llx = ldxios 1792 IF( llx ) THEN 1793 #ifdef key_iomput 1577 1794 IF( kt == kwrite ) THEN 1578 1795 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) … … 1588 1805 ENDIF 1589 1806 ENDIF 1590 END SUBROUTINE iom_rp3d 1807 END SUBROUTINE iom_rp3d_dp 1808 1591 1809 1592 1810 … … 1640 1858 !! INTERFACE iom_put 1641 1859 !!---------------------------------------------------------------------- 1642 SUBROUTINE iom_p0d ( cdname, pfield0d )1860 SUBROUTINE iom_p0d_sp( cdname, pfield0d ) 1643 1861 CHARACTER(LEN=*), INTENT(in) :: cdname 1644 REAL( wp) , INTENT(in) :: pfield0d1645 REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson1646 #if defined key_ xios1647 zz(:,:)=pfield0d1648 CALL xios_send_field(cdname, zz)1649 !CALL xios_send_field(cdname, (/pfield0d/))1862 REAL(sp) , INTENT(in) :: pfield0d 1863 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1864 #if defined key_iomput 1865 !!clem zz(:,:)=pfield0d 1866 !!clem CALL xios_send_field(cdname, zz) 1867 CALL xios_send_field(cdname, (/pfield0d/)) 1650 1868 #else 1651 1869 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings 1652 1870 #endif 1653 END SUBROUTINE iom_p0d 1654 1655 SUBROUTINE iom_p1d( cdname, pfield1d ) 1871 END SUBROUTINE iom_p0d_sp 1872 1873 SUBROUTINE iom_p0d_dp( cdname, pfield0d ) 1874 CHARACTER(LEN=*), INTENT(in) :: cdname 1875 REAL(dp) , INTENT(in) :: pfield0d 1876 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1877 #if defined key_iomput 1878 !!clem zz(:,:)=pfield0d 1879 !!clem CALL xios_send_field(cdname, zz) 1880 CALL xios_send_field(cdname, (/pfield0d/)) 1881 #else 1882 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings 1883 #endif 1884 END SUBROUTINE iom_p0d_dp 1885 1886 1887 SUBROUTINE iom_p1d_sp( cdname, pfield1d ) 1656 1888 CHARACTER(LEN=*) , INTENT(in) :: cdname 1657 REAL( wp), DIMENSION(:), INTENT(in) :: pfield1d1658 #if defined key_ xios1889 REAL(sp), DIMENSION(:), INTENT(in) :: pfield1d 1890 #if defined key_iomput 1659 1891 CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) 1660 1892 #else 1661 1893 IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings 1662 1894 #endif 1663 END SUBROUTINE iom_p1d 1664 1665 SUBROUTINE iom_p2d( cdname, pfield2d ) 1895 END SUBROUTINE iom_p1d_sp 1896 1897 SUBROUTINE iom_p1d_dp( cdname, pfield1d ) 1898 CHARACTER(LEN=*) , INTENT(in) :: cdname 1899 REAL(dp), DIMENSION(:), INTENT(in) :: pfield1d 1900 #if defined key_iomput 1901 CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) 1902 #else 1903 IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings 1904 #endif 1905 END SUBROUTINE iom_p1d_dp 1906 1907 SUBROUTINE iom_p2d_sp( cdname, pfield2d ) 1666 1908 CHARACTER(LEN=*) , INTENT(in) :: cdname 1667 REAL(wp), DIMENSION(:,:), INTENT(in) :: pfield2d 1668 #if defined key_xios 1669 CALL xios_send_field(cdname, pfield2d) 1909 REAL(sp), DIMENSION(:,:), INTENT(in) :: pfield2d 1910 IF( iom_use(cdname) ) THEN 1911 #if defined key_iomput 1912 IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 1913 CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d 1914 ELSE 1915 CALL xios_send_field( cdname, pfield2d ) 1916 ENDIF 1670 1917 #else 1671 IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings 1672 #endif 1673 END SUBROUTINE iom_p2d 1674 1675 SUBROUTINE iom_p3d( cdname, pfield3d ) 1918 WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1919 #endif 1920 ENDIF 1921 END SUBROUTINE iom_p2d_sp 1922 1923 SUBROUTINE iom_p2d_dp( cdname, pfield2d ) 1924 CHARACTER(LEN=*) , INTENT(in) :: cdname 1925 REAL(dp), DIMENSION(:,:), INTENT(in) :: pfield2d 1926 IF( iom_use(cdname) ) THEN 1927 #if defined key_iomput 1928 IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 1929 CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d 1930 ELSE 1931 CALL xios_send_field( cdname, pfield2d ) 1932 ENDIF 1933 #else 1934 WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1935 #endif 1936 ENDIF 1937 END SUBROUTINE iom_p2d_dp 1938 1939 SUBROUTINE iom_p3d_sp( cdname, pfield3d ) 1676 1940 CHARACTER(LEN=*) , INTENT(in) :: cdname 1677 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 1678 #if defined key_xios 1679 CALL xios_send_field( cdname, pfield3d ) 1941 REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 1942 IF( iom_use(cdname) ) THEN 1943 #if defined key_iomput 1944 IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 1945 CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d 1946 ELSE 1947 CALL xios_send_field( cdname, pfield3d ) 1948 ENDIF 1680 1949 #else 1681 IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings 1682 #endif 1683 END SUBROUTINE iom_p3d 1684 1685 #if defined key_xios 1950 WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1951 #endif 1952 ENDIF 1953 END SUBROUTINE iom_p3d_sp 1954 1955 SUBROUTINE iom_p3d_dp( cdname, pfield3d ) 1956 CHARACTER(LEN=*) , INTENT(in) :: cdname 1957 REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 1958 IF( iom_use(cdname) ) THEN 1959 #if defined key_iomput 1960 IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 1961 CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d 1962 ELSE 1963 CALL xios_send_field( cdname, pfield3d ) 1964 ENDIF 1965 #else 1966 WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1967 #endif 1968 ENDIF 1969 END SUBROUTINE iom_p3d_dp 1970 1971 SUBROUTINE iom_p4d_sp( cdname, pfield4d ) 1972 CHARACTER(LEN=*) , INTENT(in) :: cdname 1973 REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 1974 IF( iom_use(cdname) ) THEN 1975 #if defined key_iomput 1976 IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 1977 CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d 1978 ELSE 1979 CALL xios_send_field (cdname, pfield4d ) 1980 ENDIF 1981 #else 1982 WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1983 #endif 1984 ENDIF 1985 END SUBROUTINE iom_p4d_sp 1986 1987 SUBROUTINE iom_p4d_dp( cdname, pfield4d ) 1988 CHARACTER(LEN=*) , INTENT(in) :: cdname 1989 REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 1990 IF( iom_use(cdname) ) THEN 1991 #if defined key_iomput 1992 IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 1993 CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d 1994 ELSE 1995 CALL xios_send_field (cdname, pfield4d ) 1996 ENDIF 1997 #else 1998 WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1999 #endif 2000 ENDIF 2001 END SUBROUTINE iom_p4d_dp 2002 2003 #if defined key_iomput 1686 2004 !!---------------------------------------------------------------------- 1687 !! 'key_ xios' XIOS interface2005 !! 'key_iomput' XIOS interface 1688 2006 !!---------------------------------------------------------------------- 1689 2007 … … 1697 2015 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1698 2016 INTEGER , OPTIONAL, INTENT(in) :: nvertex 1699 REAL( wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue1700 REAL( wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area2017 REAL(dp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 2018 REAL(dp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1701 2019 LOGICAL , DIMENSION(:) , OPTIONAL, INTENT(in) :: mask 1702 2020 !!---------------------------------------------------------------------- … … 1761 2079 !!---------------------------------------------------------------------- 1762 2080 IF( PRESENT(paxis) ) THEN 1763 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=paxis ) 1764 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 1765 ENDIF 1766 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=bounds ) 1767 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 2081 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 2082 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 2083 ENDIF 2084 IF( PRESENT(bounds) ) THEN 2085 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=real(bounds, dp) ) 2086 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=real(bounds, dp) ) 2087 ELSE 2088 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid) 2089 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid) 2090 END IF 1768 2091 CALL xios_solve_inheritance() 1769 2092 END SUBROUTINE iom_set_axis_attr … … 1872 2195 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat 1873 2196 ! 1874 INTEGER :: ni, nj1875 2197 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask 1876 2198 LOGICAL, INTENT(IN) :: ldxios, ldrxios 1877 2199 !!---------------------------------------------------------------------- 1878 2200 ! 1879 ni = nlei-nldi+1 1880 nj = nlej-nldj+1 1881 ! 1882 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) 1883 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 2201 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) 2202 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0) 1884 2203 !don't define lon and lat for restart reading context. 1885 2204 IF ( .NOT.ldrxios ) & 1886 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), &1887 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))2205 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = real(RESHAPE(plon(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp), & 2206 & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp )) 1888 2207 ! 1889 2208 IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN … … 1891 2210 SELECT CASE ( cdgrd ) 1892 2211 CASE('T') ; zmask(:,:,:) = tmask(:,:,:) 1893 CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( 'iom', zmask, 'U', 1. )1894 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( 'iom', zmask, 'V', 1. )2212 CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) 2213 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) 1895 2214 CASE('W') ; zmask(:,:,2:jpk ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk) ; zmask(:,:,1) = tmask(:,:,1) 1896 2215 END SELECT 1897 2216 ! 1898 CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask( nldi:nlei,nldj:nlej,1),(/ni*nj/)) /= 0. )1899 CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask( nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. )2217 CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask(Nis0:Nie0,Njs0:Nje0,1),(/Ni_0*Nj_0 /)) /= 0. ) 2218 CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(Nis0:Nie0,Njs0:Nje0,:),(/Ni_0,Nj_0,jpk/)) /= 0. ) 1900 2219 ENDIF 1901 2220 ! 1902 2221 END SUBROUTINE set_grid 1903 1904 2222 1905 2223 SUBROUTINE set_grid_bounds( cdgrd, plon_cnr, plat_cnr, plon_pnt, plat_pnt ) … … 1914 2232 REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coord. of the point of cell (i,j) 1915 2233 ! 1916 INTEGER :: ji, jj, jn, ni, nj 1917 INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 1918 ! ! represents the bottom-left corner of cell (i,j) 2234 INTEGER :: ji, jj, jn 2235 INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 2236 ! ! represents the 2237 ! bottom-left corner of 2238 ! cell (i,j) 1919 2239 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j) 1920 2240 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells … … 1931 2251 END SELECT 1932 2252 ! 1933 ni = nlei-nldi+1 ! Dimensions of subdomain interior1934 nj = nlej-nldj+11935 !1936 2253 z_fld(:,:) = 1._wp 1937 CALL lbc_lnk( 'iom', z_fld, cdgrd, -1. ) ! Working array for location of northfold2254 CALL lbc_lnk( 'iom', z_fld, cdgrd, -1.0_wp ) ! Working array for location of northfold 1938 2255 ! 1939 2256 ! Cell vertices that can be defined 1940 DO jj = 2, jpjm1 1941 DO ji = 2, jpim1 1942 z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 1943 z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 1944 z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 1945 z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr+1) ! Top-left 1946 z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 1947 z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 1948 z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 1949 z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr+1) ! Top-left 1950 END DO 1951 END DO 1952 ! 1953 ! Cell vertices on boundries 1954 DO jn = 1, 4 1955 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1., pval=999._wp ) 1956 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1., pval=999._wp ) 1957 END DO 1958 ! 1959 ! Zero-size cells at closed boundaries if cell points provided, 1960 ! otherwise they are closed cells with unrealistic bounds 1961 IF( PRESENT(plon_pnt) .AND. PRESENT(plat_pnt) ) THEN 1962 IF( (nbondi == -1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 1963 DO jn = 1, 4 ! (West or jpni = 1), closed E-W 1964 z_bnds(jn,1,:,1) = plat_pnt(1,:) ; z_bnds(jn,1,:,2) = plon_pnt(1,:) 1965 END DO 1966 ENDIF 1967 IF( (nbondi == 1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN 1968 DO jn = 1, 4 ! (East or jpni = 1), closed E-W 1969 z_bnds(jn,nlci,:,1) = plat_pnt(nlci,:) ; z_bnds(jn,nlci,:,2) = plon_pnt(nlci,:) 1970 END DO 1971 ENDIF 1972 IF( nbondj == -1 .OR. (nbondj == 2 .AND. jperio /= 2) ) THEN 1973 DO jn = 1, 4 ! South or (jpnj = 1, not symmetric) 1974 z_bnds(jn,:,1,1) = plat_pnt(:,1) ; z_bnds(jn,:,1,2) = plon_pnt(:,1) 1975 END DO 1976 ENDIF 1977 IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio < 3 ) THEN 1978 DO jn = 1, 4 ! (North or jpnj = 1), no north fold 1979 z_bnds(jn,:,nlcj,1) = plat_pnt(:,nlcj) ; z_bnds(jn,:,nlcj,2) = plon_pnt(:,nlcj) 1980 END DO 1981 ENDIF 1982 ENDIF 1983 ! 1984 IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio >= 3 ) THEN ! Rotate cells at the north fold 1985 DO jj = 1, jpj 1986 DO ji = 1, jpi 1987 IF( z_fld(ji,jj) == -1. ) THEN 1988 z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:) 1989 z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:) 1990 z_bnds(:,ji,jj,:) = z_rot(:,:) 1991 ENDIF 1992 END DO 1993 END DO 1994 ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN ! Invert cells at the symmetric equator 1995 DO ji = 1, jpi 1996 z_rot(1:2,:) = z_bnds(3:4,ji,1,:) 1997 z_rot(3:4,:) = z_bnds(1:2,ji,1,:) 1998 z_bnds(:,ji,1,:) = z_rot(:,:) 1999 END DO 2000 ENDIF 2001 ! 2002 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), & 2003 & bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 ) 2004 ! 2005 DEALLOCATE( z_bnds, z_fld, z_rot ) 2257 DO_2D( 0, 0, 0, 0 ) 2258 z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 2259 z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 2260 z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 2261 z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr+1) ! Top-left 2262 z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr ) ! Bottom-left 2263 z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right 2264 z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right 2265 z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr+1) ! Top-left 2266 END_2D 2267 ! 2268 DO_2D( 0, 0, 0, 0 ) 2269 IF( z_fld(ji,jj) == -1. ) THEN 2270 z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:) 2271 z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:) 2272 z_bnds(:,ji,jj,:) = z_rot(:,:) 2273 ENDIF 2274 END_2D 2275 ! 2276 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,1),(/ 4,Ni_0*Nj_0 /)), dp), & 2277 & bounds_lon = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,2),(/ 4,Ni_0*Nj_0 /)), dp), nvertex=4 ) 2278 ! 2279 DEALLOCATE( z_bnds, z_fld, z_rot ) 2006 2280 ! 2007 2281 END SUBROUTINE set_grid_bounds 2008 2282 2009 2010 2283 SUBROUTINE set_grid_znl( plat ) 2011 2284 !!---------------------------------------------------------------------- … … 2017 2290 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat 2018 2291 ! 2019 INTEGER :: ni, nj,ix, iy2292 INTEGER :: ix, iy 2020 2293 REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon 2021 2294 !!---------------------------------------------------------------------- 2022 2295 ! 2023 ni=nlei-nldi+1 ! define zonal mean domain (jpj*jpk) 2024 nj=nlej-nldj+1 2025 ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0._wp 2026 ! 2027 CALL dom_ngb( -168.53, 65.03, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) 2028 ! CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 2029 CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 2030 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 2031 CALL iom_set_domain_attr("gznl", lonvalue = zlon, & 2032 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) 2033 CALL iom_set_zoom_domain_attr("znl_T", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 2034 CALL iom_set_zoom_domain_attr("znl_W", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 2296 ALLOCATE( zlon(Ni_0*Nj_0) ) ; zlon(:) = 0._wp 2297 ! 2298 ! CALL dom_ngb( -168.53_wp, 65.03_wp, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) 2299 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) 2300 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) 2301 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0) 2302 CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp), & 2303 & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp)) 2304 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj_0) 2035 2305 ! 2036 2306 CALL iom_update_file_name('ptr') … … 2046 2316 !! 2047 2317 !!---------------------------------------------------------------------- 2048 REAL( wp), DIMENSION(1) :: zz = 1.2318 REAL(dp), DIMENSION(1) :: zz = 1. 2049 2319 !!---------------------------------------------------------------------- 2050 2320 ! … … 2087 2357 f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC' , freq_op=f_op, freq_offset=f_of) 2088 2358 f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC_scalar' , freq_op=f_op, freq_offset=f_of) 2089 f_op%timestep = nn_dttrc ; f_of%timestep = 0 ; CALL iom_set_field_attr('ptrc_T' , freq_op=f_op, freq_offset=f_of) 2090 f_op%timestep = nn_dttrc ; f_of%timestep = 0 ; CALL iom_set_field_attr('diad_T' , freq_op=f_op, freq_offset=f_of) 2359 f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('ABL' , freq_op=f_op, freq_offset=f_of) 2091 2360 2092 2361 ! output file names (attribut: name) … … 2109 2378 cl1 = clgrd(jg) 2110 2379 ! Equatorial section (attributs: jbegin, ni, name_suffix) 2111 CALL dom_ngb( 0. , 0., ix, iy, cl1 )2112 CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni= jpiglo, nj=1 )2380 CALL dom_ngb( 0.0_wp, 0.0_wp, ix, iy, cl1 ) 2381 CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni=Ni0glo, nj=1 ) 2113 2382 CALL iom_get_file_attr ('Eq'//cl1, name_suffix = clsuff ) 2114 2383 CALL iom_set_file_attr ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq') … … 2269 2538 idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') 2270 2539 DO WHILE ( idx /= 0 ) 2271 cldate = iom_sdate( fjulday - r dt / rday )2540 cldate = iom_sdate( fjulday - rn_Dt / rday ) 2272 2541 clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+11:LEN_TRIM(clname)) 2273 2542 idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') … … 2276 2545 idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@') 2277 2546 DO WHILE ( idx /= 0 ) 2278 cldate = iom_sdate( fjulday - r dt / rday, ldfull = .TRUE. )2547 cldate = iom_sdate( fjulday - rn_Dt / rday, ldfull = .TRUE. ) 2279 2548 clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+15:LEN_TRIM(clname)) 2280 2549 idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@') … … 2283 2552 idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@') 2284 2553 DO WHILE ( idx /= 0 ) 2285 cldate = iom_sdate( fjulday + r dt / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE. )2554 cldate = iom_sdate( fjulday + rn_Dt / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE. ) 2286 2555 clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+9:LEN_TRIM(clname)) 2287 2556 idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@') … … 2290 2559 idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@') 2291 2560 DO WHILE ( idx /= 0 ) 2292 cldate = iom_sdate( fjulday + r dt / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE., ldfull = .TRUE. )2561 cldate = iom_sdate( fjulday + rn_Dt / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE., ldfull = .TRUE. ) 2293 2562 clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+13:LEN_TRIM(clname)) 2294 2563 idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@') … … 2335 2604 ! 2336 2605 IF ( ll24 .AND. isec == 0 ) THEN ! 00:00 of the next day -> move to 24:00 of the current day 2337 CALL ju2ymds( pjday - 1. , iyear, imonth, iday, zsec )2606 CALL ju2ymds( pjday - 1.0_wp, iyear, imonth, iday, zsec ) 2338 2607 isec = 86400 2339 2608 ENDIF … … 2361 2630 #else 2362 2631 !!---------------------------------------------------------------------- 2363 !! NOT 'key_ xios' a few dummy routines2632 !! NOT 'key_iomput' a few dummy routines 2364 2633 !!---------------------------------------------------------------------- 2365 2366 2634 SUBROUTINE iom_setkt( kt, cdname ) 2367 2635 INTEGER , INTENT(in):: kt … … 2375 2643 END SUBROUTINE iom_context_finalize 2376 2644 2645 SUBROUTINE iom_update_file_name( cdid ) 2646 CHARACTER(LEN=*), INTENT(in) :: cdid 2647 IF( .FALSE. ) WRITE(numout,*) cdid ! useless test to avoid compilation warnings 2648 END SUBROUTINE iom_update_file_name 2649 2377 2650 #endif 2378 2651 2379 2652 LOGICAL FUNCTION iom_use( cdname ) 2380 !!----------------------------------------------------------------------2381 !!----------------------------------------------------------------------2382 2653 CHARACTER(LEN=*), INTENT(in) :: cdname 2383 !!---------------------------------------------------------------------- 2384 #if defined key_xios 2654 #if defined key_iomput 2385 2655 iom_use = xios_field_is_active( cdname ) 2386 2656 #else … … 2388 2658 #endif 2389 2659 END FUNCTION iom_use 2390 2660 2661 SUBROUTINE iom_miss_val( cdname, pmiss_val ) 2662 CHARACTER(LEN=*), INTENT(in ) :: cdname 2663 REAL(wp) , INTENT(out) :: pmiss_val 2664 REAL(dp) :: ztmp_pmiss_val 2665 #if defined key_iomput 2666 ! get missing value 2667 CALL xios_get_field_attr( cdname, default_value = ztmp_pmiss_val ) 2668 pmiss_val = ztmp_pmiss_val 2669 #else 2670 IF( .FALSE. ) WRITE(numout,*) cdname, pmiss_val ! useless test to avoid compilation warnings 2671 IF( .FALSE. ) pmiss_val = 0._wp ! useless assignment to avoid compilation warnings 2672 #endif 2673 END SUBROUTINE iom_miss_val 2674 2391 2675 !!====================================================================== 2392 2676 END MODULE iom -
utils/tools/DOMAINcfg/src/iom_def.F90
r12414 r14623 13 13 PRIVATE 14 14 15 INTEGER, PARAMETER, PUBLIC :: jpdom_data = 1 !: ( 1 :jpiglo, 1 :jpjglo) !!gm to be suppressed 16 INTEGER, PARAMETER, PUBLIC :: jpdom_global = 2 !: ( 1 :jpiglo, 1 :jpjglo) 17 INTEGER, PARAMETER, PUBLIC :: jpdom_local = 3 !: One of the 3 following cases 18 INTEGER, PARAMETER, PUBLIC :: jpdom_local_full = 4 !: ( 1 :jpi , 1 :jpi ) 19 INTEGER, PARAMETER, PUBLIC :: jpdom_local_noextra = 5 !: ( 1 :nlci , 1 :nlcj ) 20 INTEGER, PARAMETER, PUBLIC :: jpdom_local_noovlap = 6 !: (nldi:nlei ,nldj:nlej ) 21 INTEGER, PARAMETER, PUBLIC :: jpdom_unknown = 7 !: No dimension checking 22 INTEGER, PARAMETER, PUBLIC :: jpdom_autoglo = 8 !: 23 INTEGER, PARAMETER, PUBLIC :: jpdom_autoglo_xy = 9 !: Automatically set horizontal dimensions only 24 INTEGER, PARAMETER, PUBLIC :: jpdom_autodta = 10 !: 15 INTEGER, PARAMETER, PUBLIC :: jpdom_global = 1 !: ( 1 :Ni0glo, 1 :Nj0glo) 16 INTEGER, PARAMETER, PUBLIC :: jpdom_local = 2 !: (Nis0: Nie0 ,Njs0: Nje0 ) 17 INTEGER, PARAMETER, PUBLIC :: jpdom_unknown = 3 !: No dimension checking 18 INTEGER, PARAMETER, PUBLIC :: jpdom_auto = 4 !: 19 INTEGER, PARAMETER, PUBLIC :: jpdom_auto_xy = 5 !: Automatically set horizontal dimensions only 20 21 INTEGER, PARAMETER, PUBLIC :: jpdom_data = jpdom_global 25 22 26 23 INTEGER, PARAMETER, PUBLIC :: jp_r8 = 200 !: write REAL(8) … … 33 30 INTEGER, PARAMETER, PUBLIC :: jpmax_vars = 1200 !: maximum number of variables in one file 34 31 INTEGER, PARAMETER, PUBLIC :: jpmax_dims = 4 !: maximum number of dimensions for one variable 35 INTEGER, PARAMETER, PUBLIC :: jpmax_digits = 5 !: maximum number of digits for the cpu number in the file name 36 32 INTEGER, PARAMETER, PUBLIC :: jpmax_digits = 9 !: maximum number of digits for the cpu number in the file name 37 33 38 34 !$AGRIF_DO_NOT_TREAT … … 46 42 LOGICAL, PUBLIC :: lxios_set = .FALSE. 47 43 48 49 50 44 TYPE, PUBLIC :: file_descriptor 51 45 CHARACTER(LEN=240) :: name !: name of the file 46 CHARACTER(LEN=3 ) :: comp !: name of component opening the file ('OCE', 'ICE'...) 52 47 INTEGER :: nfid !: identifier of the file (0 if closed) 53 48 !: jpioipsl option has been removed) … … 64 59 REAL(kind=wp), DIMENSION(jpmax_vars) :: scf !: scale_factor of the variables 65 60 REAL(kind=wp), DIMENSION(jpmax_vars) :: ofs !: add_offset of the variables 66 INTEGER :: nlev ! number of vertical levels67 61 END TYPE file_descriptor 68 62 TYPE(file_descriptor), DIMENSION(jpmax_files), PUBLIC :: iom_file !: array containing the info for all opened files … … 77 71 TYPE(RST_FIELD), PUBLIC, SAVE :: rst_wfields(max_rst_fields), rst_rfields(max_rst_fields) 78 72 ! 73 !! * Substitutions 74 # include "do_loop_substitute.h90" 79 75 !!---------------------------------------------------------------------- 80 76 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 81 !! $Id: iom_def.F90 1 0425 2018-12-19 21:54:16Z smasson $77 !! $Id: iom_def.F90 13286 2020-07-09 15:48:29Z smasson $ 82 78 !! Software governed by the CeCILL license (see ./LICENSE) 83 79 !!====================================================================== -
utils/tools/DOMAINcfg/src/iom_nf90.F90
r13204 r14623 19 19 !!---------------------------------------------------------------------- 20 20 USE dom_oce ! ocean space and time domain 21 !USE sbc_oce, ONLY: ght_abl ! abl vertical level number and height 21 22 USE lbclnk ! lateal boundary condition / mpp exchanges 22 23 USE iom_def ! iom variables definitions … … 32 33 33 34 INTERFACE iom_nf90_get 34 MODULE PROCEDURE iom_nf90_g0d, iom_nf90_g123d 35 MODULE PROCEDURE iom_nf90_g0d_sp 36 MODULE PROCEDURE iom_nf90_g0d_dp, iom_nf90_g123d_dp 35 37 END INTERFACE 36 38 INTERFACE iom_nf90_rstput 37 MODULE PROCEDURE iom_nf90_rp0123d 39 MODULE PROCEDURE iom_nf90_rp0123d_dp 38 40 END INTERFACE 39 41 40 42 !!---------------------------------------------------------------------- 41 43 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 42 !! $Id: iom_nf90.F90 1 0522 2019-01-16 08:35:15Z smasson $44 !! $Id: iom_nf90.F90 13286 2020-07-09 15:48:29Z smasson $ 43 45 !! Software governed by the CeCILL license (see ./LICENSE) 44 46 !!---------------------------------------------------------------------- 45 47 CONTAINS 46 48 47 SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kd ompar, kdlev)49 SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdlev, cdcomp ) 48 50 !!--------------------------------------------------------------------- 49 51 !! *** SUBROUTINE iom_open *** … … 55 57 LOGICAL , INTENT(in ) :: ldwrt ! read or write the file? 56 58 LOGICAL , INTENT(in ) :: ldok ! check the existence 57 INTEGER , DIMENSION(2,5), INTENT(in ), OPTIONAL :: kdompar ! domain parameters:58 INTEGER , INTENT(in ), OPTIONAL :: kdlev ! size of the third dimension59 INTEGER , INTENT(in ), OPTIONAL :: kdlev ! size of the ice/abl third dimension 60 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cdcomp ! name of component calling iom_nf90_open 59 61 60 62 CHARACTER(LEN=256) :: clinfo ! info character 61 63 CHARACTER(LEN=256) :: cltmp ! temporary character 64 CHARACTER(LEN=12 ) :: clfmt ! writing format 65 CHARACTER(LEN=3 ) :: clcomp ! name of component calling iom_nf90_open 66 INTEGER :: idg ! number of digits 62 67 INTEGER :: iln ! lengths of character 63 68 INTEGER :: istop ! temporary storage of nstop … … 69 74 INTEGER :: ihdf5 ! local variable for retrieval of value for NF90_HDF5 70 75 LOGICAL :: llclobber ! local definition of ln_clobber 71 INTEGER :: ilevels ! vertical levels72 76 !--------------------------------------------------------------------- 73 77 ! … … 76 80 ! 77 81 ! !number of vertical levels 78 IF( PRESENT(kdlev) ) THEN ; ilevels = kdlev ! use input value (useful for sea-ice) 79 ELSE ; ilevels = jpk ! by default jpk 82 IF( PRESENT(cdcomp) ) THEN 83 IF( .NOT. PRESENT(kdlev) ) CALL ctl_stop( 'iom_nf90_open: cdcomp and kdlev must both be present' ) 84 clcomp = cdcomp ! use input value 85 ELSE 86 clcomp = 'OCE' ! by default 80 87 ENDIF 81 88 ! … … 104 111 IF( ldwrt ) THEN !* the file should be open in write mode so we create it... 105 112 IF( jpnij > 1 ) THEN 106 WRITE(cltmp,'(a,a,i4.4,a)') cdname(1:iln-1), '_', narea-1, '.nc' 113 idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 114 WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' 115 WRITE(cltmp,clfmt) cdname(1:iln-1), '_', narea-1, '.nc' 107 116 cdname = TRIM(cltmp) 108 117 ENDIF … … 124 133 CALL iom_nf90_check(NF90_SET_FILL( if90id, NF90_NOFILL, idmy ), clinfo) 125 134 ! define dimensions 126 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'x', kdompar(1,1), idmy ), clinfo) 127 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y', kdompar(2,1), idmy ), clinfo) 128 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', jpk, idmy ), clinfo) 129 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) 130 IF( PRESENT(kdlev) ) & 131 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numcat', kdlev, idmy ), clinfo) 135 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'x', Ni_0, idmy ), clinfo) 136 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y', Nj_0, idmy ), clinfo) 137 SELECT CASE (clcomp) 138 CASE ('OCE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', jpk, idmy ), clinfo) 139 CASE ('ICE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numcat', kdlev, idmy ), clinfo) 140 CASE ('ABL') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', kdlev, idmy ), clinfo) 141 CASE ('SED') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numsed', kdlev, idmy ), clinfo) 142 CASE DEFAULT ; CALL ctl_stop( 'iom_nf90_open unknown component type' ) 143 END SELECT 144 CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) 132 145 ! global attributes 133 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo)134 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo)135 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2/) ), clinfo)136 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_global' , (/ jpiglo, jpjglo/) ), clinfo)137 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_local' , kdompar(:,1)), clinfo)138 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_first' , kdompar(:,2)), clinfo)139 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_last' , kdompar(:,3)), clinfo)140 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_start', kdompar(:,4)), clinfo)141 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_end' , kdompar(:,5)), clinfo)142 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ), clinfo)146 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo) 147 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo) 148 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ), clinfo) 149 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ), clinfo) 150 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ), clinfo) 151 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig0(Nis0), mjg0(Njs0) /) ), clinfo) 152 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig0(Nie0), mjg0(Nje0) /) ), clinfo) 153 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ), clinfo) 154 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ), clinfo) 155 CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ), clinfo) 143 156 ELSE !* the file should be open for read mode so it must exist... 144 157 CALL ctl_stop( TRIM(clinfo), ' should be impossible case...' ) … … 155 168 ENDDO 156 169 iom_file(kiomid)%name = TRIM(cdname) 170 iom_file(kiomid)%comp = clcomp 157 171 iom_file(kiomid)%nfid = if90id 158 172 iom_file(kiomid)%nvars = 0 159 173 iom_file(kiomid)%irec = -1 ! useless for NetCDF files, used to know if the file is in define mode 160 iom_file(kiomid)%nlev = ilevels161 174 CALL iom_nf90_check(NF90_Inquire(if90id, unlimitedDimId = iom_file(kiomid)%iduld), clinfo) 162 175 IF( iom_file(kiomid)%iduld .GE. 0 ) THEN … … 187 200 188 201 189 FUNCTION iom_nf90_varid ( kiomid, cdvar, kiv, kdimsz, kndims )202 FUNCTION iom_nf90_varid ( kiomid, cdvar, kiv, kdimsz, kndims, lduld ) 190 203 !!----------------------------------------------------------------------- 191 204 !! *** FUNCTION iom_varid *** … … 196 209 CHARACTER(len=*) , INTENT(in ) :: cdvar ! name of the variable 197 210 INTEGER , INTENT(in ) :: kiv ! 198 INTEGER, DIMENSION(:), INTENT( out), OPTIONAL :: kdimsz ! size of the dimensions 199 INTEGER, INTENT( out), OPTIONAL :: kndims ! size of the dimensions 211 INTEGER, DIMENSION(:), INTENT( out), OPTIONAL :: kdimsz ! size of each dimension 212 INTEGER , INTENT( out), OPTIONAL :: kndims ! number of dimensions 213 LOGICAL , INTENT( out), OPTIONAL :: lduld ! true if the last dimension is unlimited (time) 200 214 ! 201 215 INTEGER :: iom_nf90_varid ! iom variable Id … … 251 265 ENDIF 252 266 IF( PRESENT(kndims) ) kndims = iom_file(kiomid)%ndims(kiv) 267 IF( PRESENT( lduld) ) lduld = iom_file(kiomid)%luld(kiv) 253 268 ELSE 254 269 iom_nf90_varid = -1 ! variable not found, return error code: -1 … … 261 276 !!---------------------------------------------------------------------- 262 277 263 SUBROUTINE iom_nf90_g0d ( kiomid, kvid, pvar, kstart )278 SUBROUTINE iom_nf90_g0d_sp( kiomid, kvid, pvar, kstart ) 264 279 !!----------------------------------------------------------------------- 265 280 !! *** ROUTINE iom_nf90_g0d *** … … 269 284 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 270 285 INTEGER , INTENT(in ) :: kvid ! variable id 271 REAL( wp), INTENT( out) :: pvar ! read field286 REAL(sp), INTENT( out) :: pvar ! read field 272 287 INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 273 288 ! … … 276 291 clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) 277 292 CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) 278 END SUBROUTINE iom_nf90_g0d 279 280 281 SUBROUTINE iom_nf90_g123d( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, & 293 END SUBROUTINE iom_nf90_g0d_sp 294 295 SUBROUTINE iom_nf90_g0d_dp( kiomid, kvid, pvar, kstart ) 296 !!----------------------------------------------------------------------- 297 !! *** ROUTINE iom_nf90_g0d *** 298 !! 299 !! ** Purpose : read a scalar with NF90 300 !!----------------------------------------------------------------------- 301 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 302 INTEGER , INTENT(in ) :: kvid ! variable id 303 REAL(dp), INTENT( out) :: pvar ! read field 304 INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 305 ! 306 CHARACTER(LEN=100) :: clinfo ! info character 307 !--------------------------------------------------------------------- 308 clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) 309 CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) 310 END SUBROUTINE iom_nf90_g0d_dp 311 312 SUBROUTINE iom_nf90_g123d_dp( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, & 282 313 & pv_r1d, pv_r2d, pv_r3d ) 283 314 !!----------------------------------------------------------------------- … … 294 325 INTEGER , DIMENSION(:) , INTENT(in ) :: kcount ! number of points to be read in each axis 295 326 INTEGER , INTENT(in ) :: kx1, kx2, ky1, ky2 ! subdomain indexes 296 REAL( wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case)297 REAL( wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case)298 REAL( wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case)327 REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 328 REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 329 REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 299 330 ! 300 331 CHARACTER(LEN=100) :: clinfo ! info character … … 317 348 ENDIF 318 349 ! 319 END SUBROUTINE iom_nf90_g123d 350 END SUBROUTINE iom_nf90_g123d_dp 351 320 352 321 353 … … 491 523 END SUBROUTINE iom_nf90_putatt 492 524 493 494 SUBROUTINE iom_nf90_rp0123d( kt, kwrite, kiomid, cdvar , kvid , ktype, & 525 SUBROUTINE iom_nf90_rp0123d_dp( kt, kwrite, kiomid, cdvar , kvid , ktype, & 495 526 & pv_r0d, pv_r1d, pv_r2d, pv_r3d ) 496 527 !!-------------------------------------------------------------------- … … 505 536 INTEGER , INTENT(in) :: kvid ! variable id 506 537 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable type (default R8) 507 REAL( wp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field508 REAL( wp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field509 REAL( wp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field510 REAL( wp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field538 REAL(dp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field 539 REAL(dp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field 540 REAL(dp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field 541 REAL(dp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field 511 542 ! 512 543 INTEGER :: idims ! number of dimension … … 517 548 INTEGER, DIMENSION(4) :: idimid ! dimensions id 518 549 CHARACTER(LEN=256) :: clinfo ! info character 519 CHARACTER(LEN= 12), DIMENSION(5) :: cltmp ! temporary character520 550 INTEGER :: if90id ! nf90 file identifier 521 INTEGER :: idmy ! dummy variable522 551 INTEGER :: itype ! variable type 523 552 INTEGER, DIMENSION(4) :: ichunksz ! NetCDF4 chunk sizes. Will be computed using … … 528 557 ! ! when appropriate (currently chunking is applied to 4d fields only) 529 558 INTEGER :: idlv ! local variable 530 INTEGER :: idim3 ! id of the third dimension531 !532 ! INTEGER :: nldi_save, nlei_save !:patch before we remove periodicity and close boundaries in output files533 ! INTEGER :: nldj_save, nlej_save !:534 559 !--------------------------------------------------------------------- 535 560 ! 536 561 clinfo = ' iom_nf90_rp0123d, file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(cdvar) 537 562 if90id = iom_file(kiomid)%nfid 538 !539 ! use patch to force the writing off periodicity and close boundaries540 ! without this, issue in some model decomposition541 ! seb: patch before we remove periodicity and close boundaries in output files542 ! nldi_save = nldi ; nlei_save = nlei543 ! nldj_save = nldj ; nlej_save = nlej544 ! IF( nimpp == 1 ) nldi = 1545 ! IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi546 ! IF( njmpp == 1 ) nldj = 1547 ! IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj548 563 ! 549 564 ! define dimension variables if it is not already done … … 555 570 ENDIF 556 571 ! define the dimension variables if it is not already done 557 ! Warning: we must use the same character length in an array constructor (at least for gcc compiler) 558 cltmp = (/ 'nav_lon ', 'nav_lat ', 'nav_lev ', 'time_counter', 'numcat ' /) 559 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(1)), NF90_FLOAT , (/ 1, 2 /), iom_file(kiomid)%nvid(1) ), clinfo) 560 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(2)), NF90_FLOAT , (/ 1, 2 /), iom_file(kiomid)%nvid(2) ), clinfo) 561 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(3)), NF90_FLOAT , (/ 3 /), iom_file(kiomid)%nvid(3) ), clinfo) 562 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(4)), NF90_DOUBLE, (/ 4 /), iom_file(kiomid)%nvid(4) ), clinfo) 572 DO jd = 1, 2 573 CALL iom_nf90_check(NF90_INQUIRE_DIMENSION(if90id,jd,iom_file(kiomid)%cn_var(jd),iom_file(kiomid)%dimsz(jd,jd)),clinfo) 574 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(iom_file(kiomid)%cn_var(jd)), NF90_FLOAT , (/ 1, 2 /), & 575 & iom_file(kiomid)%nvid(jd) ), clinfo) 576 END DO 577 iom_file(kiomid)%dimsz(2,1) = iom_file(kiomid)%dimsz(2,2) ! second dim of first variable 578 iom_file(kiomid)%dimsz(1,2) = iom_file(kiomid)%dimsz(1,1) ! first dim of second variable 579 DO jd = 3, 4 580 CALL iom_nf90_check(NF90_INQUIRE_DIMENSION(if90id,jd,iom_file(kiomid)%cn_var(jd),iom_file(kiomid)%dimsz(1,jd)), clinfo) 581 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(iom_file(kiomid)%cn_var(jd)), NF90_FLOAT , (/ jd /), & 582 & iom_file(kiomid)%nvid(jd) ), clinfo) 583 END DO 563 584 ! update informations structure related the dimension variable we just added... 564 585 iom_file(kiomid)%nvars = 4 565 586 iom_file(kiomid)%luld(1:4) = (/ .FALSE., .FALSE., .FALSE., .TRUE. /) 566 iom_file(kiomid)%cn_var(1:4) = cltmp(1:4)567 587 iom_file(kiomid)%ndims(1:4) = (/ 2, 2, 1, 1 /) 568 IF( NF90_INQ_DIMID( if90id, 'numcat', idmy ) == nf90_noerr ) THEN ! add a 5th variable corresponding to the 5th dimension569 CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(5)), NF90_FLOAT , (/ 5 /), iom_file(kiomid)%nvid(5) ), clinfo)570 iom_file(kiomid)%nvars = 5571 iom_file(kiomid)%luld(5) = .FALSE.572 iom_file(kiomid)%cn_var(5) = cltmp(5)573 iom_file(kiomid)%ndims(5) = 1574 ENDIF575 ! trick: defined to 0 to say that dimension variables are defined but not yet written576 iom_file(kiomid)%dimsz(1, 1) = 0577 588 IF(lwp) WRITE(numout,*) TRIM(clinfo)//' define dimension variables done' 578 589 ENDIF … … 595 606 IF( PRESENT(pv_r0d) ) THEN ; idims = 0 596 607 ELSEIF( PRESENT(pv_r1d) ) THEN 597 IF( SIZE(pv_r1d,1) == jpk ) THEN ; idim3 = 3 598 ELSE ; idim3 = 5 599 ENDIF 600 idims = 2 ; idimid(1:idims) = (/idim3,4/) 601 ELSEIF( PRESENT(pv_r2d) ) THEN ; idims = 3 ; idimid(1:idims) = (/1,2 ,4/) 608 idims = 2 ; idimid(1:idims) = (/3,4/) 609 ELSEIF( PRESENT(pv_r2d) ) THEN ; idims = 3 ; idimid(1:idims) = (/1,2,4/) 602 610 ELSEIF( PRESENT(pv_r3d) ) THEN 603 IF( SIZE(pv_r3d,3) == jpk ) THEN ; idim3 = 3 604 ELSE ; idim3 = 5 605 ENDIF 606 idims = 4 ; idimid(1:idims) = (/1,2,idim3,4/) 611 idims = 4 ; idimid(1:idims) = (/1,2,3,4/) 607 612 ENDIF 608 613 IF( PRESENT(ktype) ) THEN ! variable external type … … 666 671 IF( PRESENT(pv_r2d) .OR. PRESENT(pv_r3d) ) THEN 667 672 idimsz(1:2) = iom_file(kiomid)%dimsz(1:2,idvar) 668 IF( idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1)) THEN669 ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej670 ELSEIF( idimsz(1) == nlci .AND. idimsz(2) == nlcj) THEN671 ix1 = 1 ; ix2 = nlci ; iy1 = 1 ; iy2 = nlcj672 ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj) THEN673 IF( idimsz(1) == Ni_0 .AND. idimsz(2) == Nj_0 ) THEN 674 ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0 675 ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN 676 ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj 677 ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN 673 678 ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj 674 679 ELSE … … 679 684 ! ============= 680 685 ! trick: is defined to 0 => dimension variable are defined but not yet written 681 IF( iom_file(kiomid)%dimsz(1, 1) == 0 ) THEN 682 CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lon' , idmy ) , clinfo ) 683 CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, glamt(ix1:ix2, iy1:iy2) ), clinfo ) 684 CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lat' , idmy ) , clinfo ) 685 CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, gphit(ix1:ix2, iy1:iy2) ), clinfo ) 686 CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lev' , idmy ), clinfo ) 687 CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, gdept_1d ), clinfo ) 688 IF( NF90_INQ_VARID( if90id, 'numcat', idmy ) == nf90_noerr ) THEN 689 CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, (/ (idlv, idlv = 1,iom_file(kiomid)%nlev) /)), clinfo ) 690 ENDIF 691 ! +++ WRONG VALUE: to be improved but not really useful... 692 CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'time_counter', idmy ), clinfo ) 693 CALL iom_nf90_check( NF90_PUT_VAR( if90id, idmy, kt ), clinfo ) 694 ! update the values of the variables dimensions size 695 CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 1, len = iom_file(kiomid)%dimsz(1,1) ), clinfo ) 696 CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 2, len = iom_file(kiomid)%dimsz(2,1) ), clinfo ) 697 iom_file(kiomid)%dimsz(1:2, 2) = iom_file(kiomid)%dimsz(1:2, 1) 698 CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 3, len = iom_file(kiomid)%dimsz(1,3) ), clinfo ) 699 iom_file(kiomid)%dimsz(1 , 4) = 1 ! unlimited dimension 686 IF( iom_file(kiomid)%dimsz(1, 4) == 0 ) THEN ! time_counter = 0 687 CALL iom_nf90_check( NF90_PUT_VAR( if90id, 1, glamt(ix1:ix2, iy1:iy2) ), clinfo ) 688 CALL iom_nf90_check( NF90_PUT_VAR( if90id, 2, gphit(ix1:ix2, iy1:iy2) ), clinfo ) 689 SELECT CASE (iom_file(kiomid)%comp) 690 CASE ('OCE') 691 CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, gdept_1d ), clinfo ) 692 ! CASE ('ABL') 693 ! CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, ght_abl ), clinfo ) 694 CASE DEFAULT 695 CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, (/ (idlv, idlv = 1,iom_file(kiomid)%dimsz(1,3)) /) ), clinfo ) 696 END SELECT 697 ! "wrong" value: to be improved but not really useful... 698 CALL iom_nf90_check( NF90_PUT_VAR( if90id, 4, kt ), clinfo ) 699 ! update the size of the variable corresponding to the unlimited dimension 700 iom_file(kiomid)%dimsz(1, 4) = 1 ! so we don't enter this IF case any more... 700 701 IF(lwp) WRITE(numout,*) TRIM(clinfo)//' write dimension variables done' 701 702 ENDIF … … 718 719 IF(lwp) WRITE(numout,*) TRIM(clinfo)//' written ok' 719 720 ENDIF 720 !721 ! nldi = nldi_save ; nlei = nlei_save722 ! nldj = nldj_save ; nlej = nlej_save723 721 ! 724 END SUBROUTINE iom_nf90_rp0123d 722 END SUBROUTINE iom_nf90_rp0123d_dp 725 723 726 724 -
utils/tools/DOMAINcfg/src/lbc_lnk_multi_generic.h90
r12414 r14623 1 #if defined DIM_2d 2 # define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j) 3 # define PTR_TYPE TYPE(PTR_2D) 4 # define PTR_ptab pt2d 1 #if defined SINGLE_PRECISION 2 # if defined DIM_2d 3 # define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j) 4 # define PTR_TYPE TYPE(PTR_2D_sp) 5 # define PTR_ptab pt2d 6 # endif 7 # if defined DIM_3d 8 # define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j,k) 9 # define PTR_TYPE TYPE(PTR_3D_sp) 10 # define PTR_ptab pt3d 11 # endif 12 # if defined DIM_4d 13 # define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j,k,l) 14 # define PTR_TYPE TYPE(PTR_4D_sp) 15 # define PTR_ptab pt4d 16 # endif 17 # define PRECISION sp 18 #else 19 # if defined DIM_2d 20 # define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j) 21 # define PTR_TYPE TYPE(PTR_2D_dp) 22 # define PTR_ptab pt2d 23 # endif 24 # if defined DIM_3d 25 # define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j,k) 26 # define PTR_TYPE TYPE(PTR_3D_dp) 27 # define PTR_ptab pt3d 28 # endif 29 # if defined DIM_4d 30 # define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j,k,l) 31 # define PTR_TYPE TYPE(PTR_4D_dp) 32 # define PTR_ptab pt4d 33 # endif 34 # define PRECISION dp 5 35 #endif 6 #if defined DIM_3d 7 # define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j,k) 8 # define PTR_TYPE TYPE(PTR_3D) 9 # define PTR_ptab pt3d 10 #endif 11 #if defined DIM_4d 12 # define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j,k,l) 13 # define PTR_TYPE TYPE(PTR_4D) 14 # define PTR_ptab pt4d 15 #endif 16 SUBROUTINE ROUTINE_MULTI( cdname & 17 & , pt1, cdna1, psgn1, pt2, cdna2, psgn2, pt3, cdna3, psgn3 & 18 & , pt4, cdna4, psgn4, pt5, cdna5, psgn5, pt6, cdna6, psgn6 & 19 & , pt7, cdna7, psgn7, pt8, cdna8, psgn8, pt9, cdna9, psgn9, cd_mpp, pval) 36 37 SUBROUTINE ROUTINE_MULTI( cdname & 38 & , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4 & 39 & , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8 & 40 & , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11 & 41 & , kfillmode, pfillval, lsend, lrecv ) 20 42 !!--------------------------------------------------------------------- 21 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 22 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 23 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 24 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 25 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9 26 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 27 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9 28 CHARACTER(len=3) , OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 29 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 43 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 44 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 45 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , pt10 , pt11 46 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 47 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, cdna10, cdna11 48 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 49 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11 50 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 51 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 52 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 30 53 !! 31 INTEGER :: kfld ! number of elements that will be attributed32 PTR_TYPE , DIMENSION( 9) :: ptab_ptr ! pointer array33 CHARACTER(len=1) , DIMENSION( 9) :: cdna_ptr ! nature of ptab_ptr grid-points34 REAL(wp) , DIMENSION( 9) :: psgn_ptr ! sign used across the north fold boundary54 INTEGER :: kfld ! number of elements that will be attributed 55 PTR_TYPE , DIMENSION(11) :: ptab_ptr ! pointer array 56 CHARACTER(len=1) , DIMENSION(11) :: cdna_ptr ! nature of ptab_ptr grid-points 57 REAL(wp) , DIMENSION(11) :: psgn_ptr ! sign used across the north fold boundary 35 58 !!--------------------------------------------------------------------- 36 59 ! … … 41 64 ! 42 65 ! ! Look if more arrays are added 43 IF( PRESENT(psgn2) ) CALL ROUTINE_LOAD( pt2, cdna2, psgn2, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 44 IF( PRESENT(psgn3) ) CALL ROUTINE_LOAD( pt3, cdna3, psgn3, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 45 IF( PRESENT(psgn4) ) CALL ROUTINE_LOAD( pt4, cdna4, psgn4, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 46 IF( PRESENT(psgn5) ) CALL ROUTINE_LOAD( pt5, cdna5, psgn5, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 47 IF( PRESENT(psgn6) ) CALL ROUTINE_LOAD( pt6, cdna6, psgn6, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 48 IF( PRESENT(psgn7) ) CALL ROUTINE_LOAD( pt7, cdna7, psgn7, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 49 IF( PRESENT(psgn8) ) CALL ROUTINE_LOAD( pt8, cdna8, psgn8, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 50 IF( PRESENT(psgn9) ) CALL ROUTINE_LOAD( pt9, cdna9, psgn9, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 66 IF( PRESENT(psgn2 ) ) CALL ROUTINE_LOAD( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 67 IF( PRESENT(psgn3 ) ) CALL ROUTINE_LOAD( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 68 IF( PRESENT(psgn4 ) ) CALL ROUTINE_LOAD( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 69 IF( PRESENT(psgn5 ) ) CALL ROUTINE_LOAD( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 70 IF( PRESENT(psgn6 ) ) CALL ROUTINE_LOAD( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 71 IF( PRESENT(psgn7 ) ) CALL ROUTINE_LOAD( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 72 IF( PRESENT(psgn8 ) ) CALL ROUTINE_LOAD( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 73 IF( PRESENT(psgn9 ) ) CALL ROUTINE_LOAD( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 74 IF( PRESENT(psgn10) ) CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 75 IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 51 76 ! 52 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, cd_mpp, pval)77 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv ) 53 78 ! 54 79 END SUBROUTINE ROUTINE_MULTI … … 72 97 ! 73 98 END SUBROUTINE ROUTINE_LOAD 99 100 #undef PRECISION 74 101 #undef ARRAY_TYPE 75 102 #undef PTR_TYPE -
utils/tools/DOMAINcfg/src/lbc_nfd_ext_generic.h90
r12414 r14623 8 8 # define L_SIZE(ptab) 1 9 9 #endif 10 #define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 10 #if defined SINGLE_PRECISION 11 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 12 # define PRECISION sp 13 #else 14 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 15 # define PRECISION dp 16 #endif 11 17 12 18 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kextj ) … … 28 34 ! 29 35 SELECT CASE ( jpni ) 30 CASE ( 1 ) ; ipj = nlcj! 1 proc only along the i-direction36 CASE ( 1 ) ; ipj = jpj ! 1 proc only along the i-direction 31 37 CASE DEFAULT ; ipj = 4 ! several proc along the i-direction 32 38 END SELECT … … 149 155 END SUBROUTINE ROUTINE_NFD 150 156 157 #undef PRECISION 151 158 #undef ARRAY_TYPE 152 159 #undef ARRAY_IN -
utils/tools/DOMAINcfg/src/lbc_nfd_generic.h90
r12414 r14623 4 4 # define F_SIZE(ptab) kfld 5 5 # if defined DIM_2d 6 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab(f) 6 # if defined SINGLE_PRECISION 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 8 # else 9 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 10 # endif 7 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 12 # define J_SIZE(ptab) SIZE(ptab(1)%pt2d,2) 8 13 # define K_SIZE(ptab) 1 9 14 # define L_SIZE(ptab) 1 10 15 # endif 11 16 # if defined DIM_3d 12 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab(f) 17 # if defined SINGLE_PRECISION 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 19 # else 20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 21 # endif 13 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 23 # define J_SIZE(ptab) SIZE(ptab(1)%pt3d,2) 14 24 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 15 25 # define L_SIZE(ptab) 1 16 26 # endif 17 27 # if defined DIM_4d 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f) 28 # if defined SINGLE_PRECISION 29 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 30 # else 31 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 32 # endif 19 33 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 34 # define J_SIZE(ptab) SIZE(ptab(1)%pt4d,2) 20 35 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 21 36 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) … … 28 43 # if defined DIM_2d 29 44 # define ARRAY_IN(i,j,k,l,f) ptab(i,j) 45 # define J_SIZE(ptab) SIZE(ptab,2) 30 46 # define K_SIZE(ptab) 1 31 47 # define L_SIZE(ptab) 1 … … 33 49 # if defined DIM_3d 34 50 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) 51 # define J_SIZE(ptab) SIZE(ptab,2) 35 52 # define K_SIZE(ptab) SIZE(ptab,3) 36 53 # define L_SIZE(ptab) 1 … … 38 55 # if defined DIM_4d 39 56 # define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) 57 # define J_SIZE(ptab) SIZE(ptab,2) 40 58 # define K_SIZE(ptab) SIZE(ptab,3) 41 59 # define L_SIZE(ptab) SIZE(ptab,4) 42 60 # endif 43 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 61 # if defined SINGLE_PRECISION 62 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 63 # else 64 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 65 # endif 44 66 #endif 67 68 # if defined SINGLE_PRECISION 69 # define PRECISION sp 70 # else 71 # define PRECISION dp 72 # endif 45 73 46 74 #if defined MULTI … … 54 82 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 55 83 ! 56 INTEGER :: ji, jj, jk, jl, jh,jf ! dummy loop indices57 INTEGER :: ipi, ipj, ipk, ipl,ipf ! dimension of the input array58 INTEGER :: i jt, iju, ipjm184 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 85 INTEGER :: ipj, ipk, ipl, ipf ! dimension of the input array 86 INTEGER :: ii1, ii2, ij1, ij2 59 87 !!---------------------------------------------------------------------- 60 88 ! 61 ipk = K_SIZE(ptab) ! 3rd dimension 89 ipj = J_SIZE(ptab) ! 2nd dimension 90 ipk = K_SIZE(ptab) ! 3rd - 62 91 ipl = L_SIZE(ptab) ! 4th - 63 92 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 64 !65 !66 SELECT CASE ( jpni )67 CASE ( 1 ) ; ipj = nlcj ! 1 proc only along the i-direction68 CASE DEFAULT ; ipj = 4 ! several proc along the i-direction69 END SELECT70 ipjm1 = ipj-171 72 93 ! 73 94 DO jf = 1, ipf ! Loop on the number of arrays to be treated … … 79 100 SELECT CASE ( NAT_IN(jf) ) 80 101 CASE ( 'T' , 'W' ) ! T-, W-point 81 DO ji = 2, jpiglo 82 ijt = jpiglo-ji+2 83 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) 84 END DO 85 ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-2,:,:,jf) 86 DO ji = jpiglo/2+1, jpiglo 87 ijt = jpiglo-ji+2 88 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf) 89 END DO 102 DO jl = 1, ipl; DO jk = 1, ipk 103 ! 104 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 105 DO jj = 1, nn_hls 106 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 107 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 108 ! 109 DO ji = 1, nn_hls ! first nn_hls points 110 ii1 = ji ! ends at: nn_hls 111 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 112 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 113 END DO 114 DO ji = 1, 1 ! point nn_hls+1 115 ii1 = nn_hls + ji 116 ii2 = ii1 117 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 118 END DO 119 DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 120 ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 121 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 122 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 123 END DO 124 DO ji = 1, 1 ! point jpiglo - nn_hls + 1 125 ii1 = jpiglo - nn_hls + ji 126 ii2 = nn_hls + ji 127 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 128 END DO 129 DO ji = 1, nn_hls-1 ! last nn_hls-1 points 130 ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 131 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 132 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 133 END DO 134 END DO 135 ! 136 ! line number ipj-nn_hls : right half 137 DO jj = 1, 1 138 ij1 = ipj - nn_hls 139 ij2 = ij1 ! same line 140 ! 141 DO ji = 1, Ni0glo/2-1 ! points from jpiglo/2+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 142 ii1 = jpiglo/2 + ji + 1 ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls - 1) + 1 = jpiglo - nn_hls 143 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1) + 1 = nn_hls + 2 144 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 145 END DO 146 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) 147 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls 148 ii1 = ji ! ends at: nn_hls 149 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 150 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 151 END DO 152 ! ! last nn_hls-1 points: have been / will done by e-w periodicity 153 END DO 154 ! 155 END DO; END DO 90 156 CASE ( 'U' ) ! U-point 91 DO ji = 1, jpiglo-1 92 iju = jpiglo-ji+1 93 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) 94 END DO 95 ARRAY_IN( 1 ,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-2,:,:,jf) 96 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-2,:,:,jf) 97 DO ji = jpiglo/2, jpiglo-1 98 iju = jpiglo-ji+1 99 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf) 100 END DO 157 DO jl = 1, ipl; DO jk = 1, ipk 158 ! 159 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 160 DO jj = 1, nn_hls 161 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 162 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 163 ! 164 DO ji = 1, nn_hls ! first nn_hls points 165 ii1 = ji ! ends at: nn_hls 166 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 167 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 168 END DO 169 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 170 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 171 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 172 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 173 END DO 174 DO ji = 1, nn_hls ! last nn_hls points 175 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 176 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 177 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 178 END DO 179 END DO 180 ! 181 ! line number ipj-nn_hls : right half 182 DO jj = 1, 1 183 ij1 = ipj - nn_hls 184 ij2 = ij1 ! same line 185 ! 186 DO ji = 1, Ni0glo/2 ! points from jpiglo/2+1 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 187 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 188 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 189 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 190 END DO 191 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) 192 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls 193 ii1 = ji ! ends at: nn_hls 194 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 195 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 196 END DO 197 ! ! last nn_hls-1 points: have been / will done by e-w periodicity 198 END DO 199 ! 200 END DO; END DO 101 201 CASE ( 'V' ) ! V-point 102 DO ji = 2, jpiglo 103 ijt = jpiglo-ji+2 104 ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) 105 ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-3,:,:,jf) 106 END DO 107 ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-3,:,:,jf) 202 DO jl = 1, ipl; DO jk = 1, ipk 203 ! 204 ! last nn_hls+1 lines (from ipj to ipj-nn_hls) : full 205 DO jj = 1, nn_hls+1 206 ij1 = ipj - jj + 1 ! ends at: ipj - ( nn_hls + 1 ) + 1 = ipj - nn_hls 207 ij2 = ipj - 2*nn_hls + jj - 2 ! ends at: ipj - 2*nn_hls + nn_hls + 1 - 2 = ipj - nn_hls - 1 208 ! 209 DO ji = 1, nn_hls ! first nn_hls points 210 ii1 = ji ! ends at: nn_hls 211 ii2 = 2*nn_hls + 2 - ji ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 212 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 213 END DO 214 DO ji = 1, 1 ! point nn_hls+1 215 ii1 = nn_hls + ji 216 ii2 = ii1 217 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 218 END DO 219 DO ji = 1, Ni0glo - 1 ! points from nn_hls+2 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 220 ii1 = 2 + nn_hls + ji - 1 ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 221 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 222 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 223 END DO 224 DO ji = 1, 1 ! point jpiglo - nn_hls + 1 225 ii1 = jpiglo - nn_hls + ji 226 ii2 = nn_hls + ji 227 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 228 END DO 229 DO ji = 1, nn_hls-1 ! last nn_hls-1 points 230 ii1 = jpiglo - nn_hls + 1 + ji ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 231 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 232 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 233 END DO 234 END DO 235 ! 236 END DO; END DO 108 237 CASE ( 'F' ) ! F-point 109 DO ji = 1, jpiglo-1 110 iju = jpiglo-ji+1 111 ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) 112 ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-3,:,:,jf) 113 END DO 114 ARRAY_IN( 1 ,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-3,:,:,jf) 115 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-3,:,:,jf) 116 END SELECT 238 DO jl = 1, ipl; DO jk = 1, ipk 239 ! 240 ! last nn_hls+1 lines (from ipj to ipj-nn_hls) : full 241 DO jj = 1, nn_hls+1 242 ij1 = ipj - jj + 1 ! ends at: ipj - ( nn_hls + 1 ) + 1 = ipj - nn_hls 243 ij2 = ipj - 2*nn_hls + jj - 2 ! ends at: ipj - 2*nn_hls + nn_hls + 1 - 2 = ipj - nn_hls - 1 244 ! 245 DO ji = 1, nn_hls ! first nn_hls points 246 ii1 = ji ! ends at: nn_hls 247 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 248 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 249 END DO 250 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 251 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 252 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 253 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 254 END DO 255 DO ji = 1, nn_hls ! last nn_hls points 256 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 257 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 258 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 259 END DO 260 END DO 261 ! 262 END DO; END DO 263 END SELECT ! NAT_IN(jf) 117 264 ! 118 265 CASE ( 5 , 6 ) ! * North fold F-point pivot … … 120 267 SELECT CASE ( NAT_IN(jf) ) 121 268 CASE ( 'T' , 'W' ) ! T-, W-point 122 DO ji = 1, jpiglo 123 ijt = jpiglo-ji+1 124 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-1,:,:,jf) 125 END DO 269 DO jl = 1, ipl; DO jk = 1, ipk 270 ! 271 ! first: line number ipj-nn_hls : 3 points 272 DO jj = 1, 1 273 ij1 = ipj - nn_hls 274 ij2 = ij1 ! same line 275 ! 276 DO ji = 1, 1 ! points from jpiglo/2+1 277 ii1 = jpiglo/2 + ji 278 ii2 = jpiglo/2 - ji + 1 279 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign... 280 END DO 281 DO ji = 1, 1 ! points jpiglo - nn_hls 282 ii1 = jpiglo - nn_hls + ji - 1 283 ii2 = nn_hls + ji 284 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign... 285 END DO 286 DO ji = 1, 1 ! point nn_hls: redo it just in case (if e-w periodocity already done) 287 ! ! as we just changed point jpiglo - nn_hls 288 ii1 = nn_hls + ji - 1 289 ii2 = nn_hls + ji 290 ARRAY_IN(ii1,ij1,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) ! Warning: pb with sign... 291 END DO 292 END DO 293 ! 294 ! Second: last nn_hls lines (from ipj to ipj-nn_hls+1) : full 295 DO jj = 1, nn_hls 296 ij1 = ipj + 1 - jj ! ends at: ipj + 1 - nn_hls 297 ij2 = ipj - 2*nn_hls + jj ! ends at: ipj - 2*nn_hls + nn_hls = ipj - nn_hls 298 ! 299 DO ji = 1, nn_hls ! first nn_hls points 300 ii1 = ji ! ends at: nn_hls 301 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 302 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 303 END DO 304 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 305 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 306 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 307 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 308 END DO 309 DO ji = 1, nn_hls ! last nn_hls points 310 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 311 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 312 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 313 END DO 314 END DO 315 ! 316 END DO; END DO 126 317 CASE ( 'U' ) ! U-point 127 DO ji = 1, jpiglo-1 128 iju = jpiglo-ji 129 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-1,:,:,jf) 130 END DO 131 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-1,:,:,jf) 318 DO jl = 1, ipl; DO jk = 1, ipk 319 ! 320 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 321 DO jj = 1, nn_hls 322 ij1 = ipj + 1 - jj ! ends at: ipj + 1 - nn_hls 323 ij2 = ipj - 2*nn_hls + jj ! ends at: ipj - 2*nn_hls + nn_hls = ipj - nn_hls 324 ! 325 DO ji = 1, nn_hls-1 ! first nn_hls-1 points 326 ii1 = ji ! ends at: nn_hls-1 327 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 328 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 329 END DO 330 DO ji = 1, 1 ! point nn_hls 331 ii1 = nn_hls + ji - 1 332 ii2 = jpiglo - ii1 333 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 334 END DO 335 DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls) 336 ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 337 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1 338 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 339 END DO 340 DO ji = 1, 1 ! point jpiglo - nn_hls 341 ii1 = jpiglo - nn_hls + ji - 1 342 ii2 = ii1 343 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 344 END DO 345 DO ji = 1, nn_hls ! last nn_hls points 346 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 347 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls 348 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 349 END DO 350 END DO 351 ! 352 END DO; END DO 132 353 CASE ( 'V' ) ! V-point 133 DO ji = 1, jpiglo 134 ijt = jpiglo-ji+1 135 ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) 136 END DO 137 DO ji = jpiglo/2+1, jpiglo 138 ijt = jpiglo-ji+1 139 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf) 140 END DO 354 DO jl = 1, ipl; DO jk = 1, ipk 355 ! 356 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 357 DO jj = 1, nn_hls 358 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 359 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 360 ! 361 DO ji = 1, nn_hls ! first nn_hls points 362 ii1 = ji ! ends at: nn_hls 363 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 364 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 365 END DO 366 DO ji = 1, Ni0glo ! points from nn_hls to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 367 ii1 = nn_hls + ji ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 368 ii2 = jpiglo - nn_hls - ji + 1 ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 369 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 370 END DO 371 DO ji = 1, nn_hls ! last nn_hls points 372 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 373 ii2 = jpiglo - nn_hls + 1 - ji ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 374 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 375 END DO 376 END DO 377 ! 378 ! line number ipj-nn_hls : right half 379 DO jj = 1, 1 380 ij1 = ipj - nn_hls 381 ij2 = ij1 ! same line 382 ! 383 DO ji = 1, Ni0glo/2 ! points from jpiglo/2+1 to jpiglo - nn_hls (note: Ni0glo = jpiglo - 2*nn_hls) 384 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 385 ii2 = jpiglo/2 - ji + 1 ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 386 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 387 END DO 388 DO ji = 1, nn_hls ! first nn_hls points: redo them just in case (if e-w periodocity already done) 389 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls 390 ii1 = ji ! ends at: nn_hls 391 ii2 = 2*nn_hls + 1 - ji ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 392 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 393 END DO 394 ! ! last nn_hls points: have been / will done by e-w periodicity 395 END DO 396 ! 397 END DO; END DO 141 398 CASE ( 'F' ) ! F-point 142 DO ji = 1, jpiglo-1 143 iju = jpiglo-ji 144 ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) 145 END DO 146 ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-2,:,:,jf) 147 DO ji = jpiglo/2+1, jpiglo-1 148 iju = jpiglo-ji 149 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf) 150 END DO 151 END SELECT 399 DO jl = 1, ipl; DO jk = 1, ipk 400 ! 401 ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 402 DO jj = 1, nn_hls 403 ij1 = ipj - jj + 1 ! ends at: ipj - nn_hls + 1 404 ij2 = ipj - 2*nn_hls + jj - 1 ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 405 ! 406 DO ji = 1, nn_hls-1 ! first nn_hls-1 points 407 ii1 = ji ! ends at: nn_hls-1 408 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 409 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 410 END DO 411 DO ji = 1, 1 ! point nn_hls 412 ii1 = nn_hls + ji - 1 413 ii2 = jpiglo - ii1 414 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 415 END DO 416 DO ji = 1, Ni0glo - 1 ! points from nn_hls+1 to jpiglo - nn_hls - 1 (note: Ni0glo = jpiglo - 2*nn_hls) 417 ii1 = nn_hls + ji ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 418 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1 419 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 420 END DO 421 DO ji = 1, 1 ! point jpiglo - nn_hls 422 ii1 = jpiglo - nn_hls + ji - 1 423 ii2 = ii1 424 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 425 END DO 426 DO ji = 1, nn_hls ! last nn_hls points 427 ii1 = jpiglo - nn_hls + ji ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 428 ii2 = jpiglo - nn_hls - ji ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls 429 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 430 END DO 431 END DO 432 ! 433 ! line number ipj-nn_hls : right half 434 DO jj = 1, 1 435 ij1 = ipj - nn_hls 436 ij2 = ij1 ! same line 437 ! 438 DO ji = 1, Ni0glo/2-1 ! points from jpiglo/2+1 to jpiglo - nn_hls-1 (note: Ni0glo = jpiglo - 2*nn_hls) 439 ii1 = jpiglo/2 + ji ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 440 ii2 = jpiglo/2 - ji ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1 ) = nn_hls + 1 441 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 442 END DO 443 DO ji = 1, nn_hls-1 ! first nn_hls-1 points: redo them just in case (if e-w periodocity already done) 444 ! ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hl-1 445 ii1 = ji ! ends at: nn_hls 446 ii2 = 2*nn_hls - ji ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 447 ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 448 END DO 449 ! ! last nn_hls points: have been / will done by e-w periodicity 450 END DO 451 ! 452 END DO; END DO 453 END SELECT ! NAT_IN(jf) 152 454 ! 153 CASE DEFAULT ! * closed : the code probably never go through 154 ! 155 SELECT CASE ( NAT_IN(jf) ) 156 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 157 ARRAY_IN(:, 1 ,:,:,jf) = 0._wp 158 ARRAY_IN(:,ipj,:,:,jf) = 0._wp 159 CASE ( 'F' ) ! F-point 160 ARRAY_IN(:,ipj,:,:,jf) = 0._wp 161 END SELECT 162 ! 163 END SELECT ! npolj 455 END SELECT ! npolj 164 456 ! 165 END DO 457 END DO ! ipf 166 458 ! 167 459 END SUBROUTINE ROUTINE_NFD 168 460 461 #undef PRECISION 169 462 #undef ARRAY_TYPE 170 463 #undef ARRAY_IN 171 464 #undef NAT_IN 172 465 #undef SGN_IN 466 #undef J_SIZE 173 467 #undef K_SIZE 174 468 #undef L_SIZE -
utils/tools/DOMAINcfg/src/lbc_nfd_nogather_generic.h90
r12414 r14623 4 4 # define F_SIZE(ptab) kfld 5 5 # if defined DIM_2d 6 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab(f) 6 # if defined SINGLE_PRECISION 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 8 # else 9 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 10 # endif 7 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 8 12 # define K_SIZE(ptab) 1 … … 10 14 # endif 11 15 # if defined DIM_3d 12 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab(f) 16 # if defined SINGLE_PRECISION 17 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 18 # else 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 20 # endif 13 21 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 14 22 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) … … 16 24 # endif 17 25 # if defined DIM_4d 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f) 26 # if defined SINGLE_PRECISION 27 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 28 # else 29 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 30 # endif 19 31 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 20 32 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 21 33 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 22 34 # endif 23 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab2(f) 35 # if defined SINGLE_PRECISION 36 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab2(f) 37 # else 38 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab2(f) 39 # endif 24 40 # define J_SIZE(ptab2) SIZE(ptab2(1)%pt4d,2) 25 41 # define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt4d(i,j,k,l) … … 44 60 # define L_SIZE(ptab) SIZE(ptab,4) 45 61 # endif 46 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l)47 62 # define J_SIZE(ptab2) SIZE(ptab2,2) 48 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 49 # define ARRAY2_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 50 #endif 51 63 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l) 64 # if defined SINGLE_PRECISION 65 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 66 # define ARRAY2_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 67 # else 68 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 69 # define ARRAY2_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 70 # endif 71 # endif 72 # ifdef SINGLE_PRECISION 73 # define PRECISION sp 74 # else 75 # define PRECISION dp 76 # endif 52 77 SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld ) 53 78 !!---------------------------------------------------------------------- … … 57 82 !! 58 83 !!---------------------------------------------------------------------- 59 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied60 ARRAY2_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied84 ARRAY_TYPE(:,:,:,:,:) 85 ARRAY2_TYPE(:,:,:,:,:) 61 86 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 62 87 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 63 88 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 64 89 ! 65 INTEGER :: ji, jj, jk, 66 INTEGER :: ipi, ipj, ipk, ipl, ipf 67 INTEGER :: ijt, iju, ij pj, ijpjp1, ijta, ijua, jia, startloop, endloop90 INTEGER :: ji, jj, jk, jn, ii, jl, jh, jf ! dummy loop indices 91 INTEGER :: ipi, ipj, ipk, ipl, ipf, iij, ijj ! dimension of the input array 92 INTEGER :: ijt, iju, ijta, ijua, jia, startloop, endloop 68 93 LOGICAL :: l_fast_exchanges 69 94 !!---------------------------------------------------------------------- … … 74 99 ! 75 100 ! Security check for further developments 76 IF ( ipf > 1 ) THEN 77 write(6,*) 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation' 78 write(6,*) 'You should not be there...' 79 STOP 80 ENDIF 81 ! 82 ijpj = 1 ! index of first modified line 83 ijpjp1 = 2 ! index + 1 84 101 IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 85 102 ! 2nd dimension determines exchange speed 86 103 IF (ipj == 1 ) THEN … … 99 116 ! 100 117 CASE ( 'T' , 'W' ) ! T-, W-point 101 IF ( nimpp /= 1 ) THEN ; startloop = 1 102 ELSE ; startloop = 2 103 ENDIF 104 ! 105 DO jl = 1, ipl; DO jk = 1, ipk 106 DO ji = startloop, nlci 107 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 108 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 118 IF ( nimpp /= 1 ) THEN ; startloop = 1 119 ELSE ; startloop = 1 + nn_hls 120 ENDIF 121 ! 122 DO jl = 1, ipl; DO jk = 1, ipk 123 DO jj = 1, nn_hls 124 ijj = jpj -jj +1 125 DO ji = startloop, jpi 126 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 127 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 128 END DO 109 129 END DO 110 130 END DO; END DO 111 131 IF( nimpp == 1 ) THEN 112 132 DO jl = 1, ipl; DO jk = 1, ipk 113 ARRAY_IN(1,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-2,jk,jl,jf) 114 END DO; END DO 115 ENDIF 116 ! 117 IF ( .NOT. l_fast_exchanges ) THEN 118 IF( nimpp >= jpiglo/2+1 ) THEN 133 DO jj = 1, nn_hls 134 ijj = jpj -jj +1 135 DO ii = 0, nn_hls-1 136 ARRAY_IN(ii+1,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,jk,jl,jf) 137 END DO 138 END DO 139 END DO; END DO 140 ENDIF 141 ! 142 IF ( .NOT. l_fast_exchanges ) THEN 143 IF( nimpp >= Ni0glo/2+2 ) THEN 119 144 startloop = 1 120 ELSEIF( nimpp+ nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1) THEN121 startloop = jpiglo/2+1 - nimpp + 1122 ELSE 123 startloop = nlci + 1124 ENDIF 125 IF( startloop <= nlci ) THEN145 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 146 startloop = Ni0glo/2+2 - nimpp + nn_hls 147 ELSE 148 startloop = jpi + 1 149 ENDIF 150 IF( startloop <= jpi ) THEN 126 151 DO jl = 1, ipl; DO jk = 1, ipk 127 DO ji = startloop, nlci128 ijt = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 4152 DO ji = startloop, jpi 153 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 129 154 jia = ji + nimpp - 1 130 155 ijta = jpiglo - jia + 2 131 156 IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 132 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-1,jk,jl,jf)157 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+nn_hls,jpj-nn_hls,jk,jl,jf) 133 158 ELSE 134 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)159 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 135 160 ENDIF 136 161 END DO … … 138 163 ENDIF 139 164 ENDIF 140 141 165 CASE ( 'U' ) ! U-point 142 IF( nimpp + nlci - 1 /= jpiglo ) THEN143 endloop = nlci166 IF( nimpp + jpi - 1 /= jpiglo ) THEN 167 endloop = jpi 144 168 ELSE 145 endloop = nlci - 1 146 ENDIF 147 DO jl = 1, ipl; DO jk = 1, ipk 148 DO ji = 1, endloop 149 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 150 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 169 endloop = jpi - nn_hls 170 ENDIF 171 DO jl = 1, ipl; DO jk = 1, ipk 172 DO jj = 1, nn_hls 173 ijj = jpj -jj +1 174 DO ji = 1, endloop 175 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 176 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 177 END DO 151 178 END DO 152 179 END DO; END DO 153 180 IF (nimpp .eq. 1) THEN 154 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 155 ENDIF 156 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 157 ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 158 ENDIF 159 ! 160 IF ( .NOT. l_fast_exchanges ) THEN 161 IF( nimpp + nlci - 1 /= jpiglo ) THEN 162 endloop = nlci 163 ELSE 164 endloop = nlci - 1 165 ENDIF 166 IF( nimpp >= jpiglo/2 ) THEN 167 startloop = 1 168 ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 169 startloop = jpiglo/2 - nimpp + 1 181 DO jj = 1, nn_hls 182 ijj = jpj -jj +1 183 DO ii = 0, nn_hls-1 184 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf) 185 END DO 186 END DO 187 ENDIF 188 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 189 DO jj = 1, nn_hls 190 ijj = jpj -jj +1 191 DO ii = 1, nn_hls 192 ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf) 193 END DO 194 END DO 195 ENDIF 196 ! 197 IF ( .NOT. l_fast_exchanges ) THEN 198 IF( nimpp + jpi - 1 /= jpiglo ) THEN 199 endloop = jpi 200 ELSE 201 endloop = jpi - nn_hls 202 ENDIF 203 IF( nimpp >= Ni0glo/2+1 ) THEN 204 startloop = nn_hls 205 ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN 206 startloop = Ni0glo/2+1 - nimpp + nn_hls 170 207 ELSE 171 208 startloop = endloop + 1 … … 174 211 DO jl = 1, ipl; DO jk = 1, ipk 175 212 DO ji = startloop, endloop 176 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 3177 jia = ji + nimpp - 1 178 ijua = jpiglo - jia + 1 213 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 214 jia = ji + nimpp - 1 215 ijua = jpiglo - jia + 1 179 216 IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 180 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-1,jk,jl,jf)217 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,jpj-nn_hls,jk,jl,jf) 181 218 ELSE 182 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)219 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 183 220 ENDIF 184 221 END DO … … 189 226 CASE ( 'V' ) ! V-point 190 227 IF( nimpp /= 1 ) THEN 191 startloop = 1 228 startloop = 1 192 229 ELSE 193 startloop = 2 194 ENDIF 195 IF ( .NOT. l_fast_exchanges ) THEN 196 DO jl = 1, ipl; DO jk = 1, ipk 197 DO ji = startloop, nlci 198 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 199 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 200 END DO 201 END DO; END DO 202 ENDIF 203 DO jl = 1, ipl; DO jk = 1, ipk 204 DO ji = startloop, nlci 205 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 206 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 230 startloop = 1 + nn_hls 231 ENDIF 232 IF ( .NOT. l_fast_exchanges ) THEN 233 DO jl = 1, ipl; DO jk = 1, ipk 234 DO jj = 2, nn_hls+1 235 ijj = jpj -jj +1 236 DO ji = startloop, jpi 237 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 238 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 239 END DO 240 END DO 241 END DO; END DO 242 ENDIF 243 DO jl = 1, ipl; DO jk = 1, ipk 244 DO ji = startloop, jpi 245 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 246 ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,1,jk,jl,jf) 207 247 END DO 208 248 END DO; END DO 209 249 IF (nimpp .eq. 1) THEN 210 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-3,:,:,jf) 250 DO jj = 1, nn_hls 251 ijj = jpj-jj+1 252 DO ii = 0, nn_hls-1 253 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,:,:,jf) 254 END DO 255 END DO 211 256 ENDIF 212 257 CASE ( 'F' ) ! F-point 213 IF( nimpp + nlci - 1 /= jpiglo ) THEN214 endloop = nlci258 IF( nimpp + jpi - 1 /= jpiglo ) THEN 259 endloop = jpi 215 260 ELSE 216 endloop = nlci - 1 217 ENDIF 218 IF ( .NOT. l_fast_exchanges ) THEN 219 DO jl = 1, ipl; DO jk = 1, ipk 220 DO ji = 1, endloop 221 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 222 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 223 END DO 261 endloop = jpi - nn_hls 262 ENDIF 263 IF ( .NOT. l_fast_exchanges ) THEN 264 DO jl = 1, ipl; DO jk = 1, ipk 265 DO jj = 2, nn_hls+1 266 ijj = jpj -jj +1 267 DO ji = 1, endloop 268 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 269 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 270 END DO 271 END DO 224 272 END DO; END DO 225 273 ENDIF 226 274 DO jl = 1, ipl; DO jk = 1, ipk 227 275 DO ji = 1, endloop 228 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 229 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 230 END DO 231 END DO; END DO 232 IF (nimpp .eq. 1) THEN 233 ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-3,:,:,jf) 234 IF ( .NOT. l_fast_exchanges ) & 235 ARRAY_IN(1,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 236 ENDIF 237 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 238 ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-3,:,:,jf) 239 IF ( .NOT. l_fast_exchanges ) & 240 ARRAY_IN(nlci,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 241 ENDIF 242 ! 243 END SELECT 276 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 277 ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf) 278 END DO 279 END DO; END DO 280 IF (nimpp .eq. 1) THEN 281 DO ii = 1, nn_hls 282 ARRAY_IN(ii,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls-1,:,:,jf) 283 END DO 284 IF ( .NOT. l_fast_exchanges ) THEN 285 DO jj = 1, nn_hls 286 ijj = jpj -jj 287 DO ii = 0, nn_hls-1 288 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf) 289 END DO 290 END DO 291 ENDIF 292 ENDIF 293 IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN 294 DO ii = 1, nn_hls 295 ARRAY_IN(jpi-ii+1,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:,jf) 296 END DO 297 IF ( .NOT. l_fast_exchanges ) THEN 298 DO jj = 1, nn_hls 299 ijj = jpj -jj 300 DO ii = 1, nn_hls 301 ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf) 302 END DO 303 END DO 304 ENDIF 305 ENDIF 306 ! 307 END SELECT 244 308 ! 245 309 CASE ( 5, 6 ) ! * North fold F-point pivot … … 248 312 CASE ( 'T' , 'W' ) ! T-, W-point 249 313 DO jl = 1, ipl; DO jk = 1, ipk 250 DO ji = 1, nlci 251 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 252 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 253 END DO 314 DO jj = 1, nn_hls 315 ijj = jpj-jj+1 316 DO ji = 1, jpi 317 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 318 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 319 END DO 320 END DO 254 321 END DO; END DO 255 322 ! 256 323 CASE ( 'U' ) ! U-point 257 IF( nimpp + nlci - 1 /= jpiglo ) THEN258 endloop = nlci324 IF( nimpp + jpi - 1 /= jpiglo ) THEN 325 endloop = jpi 259 326 ELSE 260 endloop = nlci - 1 261 ENDIF 262 DO jl = 1, ipl; DO jk = 1, ipk 263 DO ji = 1, endloop 264 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 265 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 266 END DO 267 END DO; END DO 268 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 269 DO jl = 1, ipl; DO jk = 1, ipk 270 ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf) 327 endloop = jpi - nn_hls 328 ENDIF 329 DO jl = 1, ipl; DO jk = 1, ipk 330 DO jj = 1, nn_hls 331 ijj = jpj-jj+1 332 DO ji = 1, endloop 333 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 334 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 335 END DO 336 END DO 337 END DO; END DO 338 IF(nimpp + jpi - 1 .eq. jpiglo) THEN 339 DO jl = 1, ipl; DO jk = 1, ipk 340 DO jj = 1, nn_hls 341 ijj = jpj-jj+1 342 DO ii = 1, nn_hls 343 iij = jpi-ii+1 344 ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj,jk,jl,jf) 345 END DO 346 END DO 271 347 END DO; END DO 272 348 ENDIF … … 274 350 CASE ( 'V' ) ! V-point 275 351 DO jl = 1, ipl; DO jk = 1, ipk 276 DO ji = 1, nlci 277 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 278 ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 352 DO jj = 1, nn_hls 353 ijj = jpj -jj +1 354 DO ji = 1, jpi 355 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 356 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 357 END DO 279 358 END DO 280 359 END DO; END DO 281 360 282 361 IF ( .NOT. l_fast_exchanges ) THEN 283 IF( nimpp >= jpiglo/2+1) THEN362 IF( nimpp >= Ni0glo/2+2 ) THEN 284 363 startloop = 1 285 ELSEIF( nimpp+ nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1) THEN286 startloop = jpiglo/2+1 - nimpp + 1287 ELSE 288 startloop = nlci + 1289 ENDIF 290 IF( startloop <= nlci ) THEN291 DO jl = 1, ipl; DO jk = 1, ipk 292 DO ji = startloop, nlci293 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3294 ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)295 END DO364 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 365 startloop = Ni0glo/2+2 - nimpp + nn_hls 366 ELSE 367 startloop = jpi + 1 368 ENDIF 369 IF( startloop <= jpi ) THEN 370 DO jl = 1, ipl; DO jk = 1, ipk 371 DO ji = startloop, jpi 372 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 373 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 374 END DO 296 375 END DO; END DO 297 376 ENDIF … … 299 378 ! 300 379 CASE ( 'F' ) ! F-point 301 IF( nimpp + nlci - 1 /= jpiglo ) THEN302 endloop = nlci380 IF( nimpp + jpi - 1 /= jpiglo ) THEN 381 endloop = jpi 303 382 ELSE 304 endloop = nlci - 1 305 ENDIF 306 DO jl = 1, ipl; DO jk = 1, ipk 307 DO ji = 1, endloop 308 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 309 ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 310 END DO 311 END DO; END DO 312 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 313 DO jl = 1, ipl; DO jk = 1, ipk 314 ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-2,jk,jl,jf) 315 END DO; END DO 316 ENDIF 317 ! 318 IF ( .NOT. l_fast_exchanges ) THEN 319 IF( nimpp + nlci - 1 /= jpiglo ) THEN 320 endloop = nlci 321 ELSE 322 endloop = nlci - 1 323 ENDIF 324 IF( nimpp >= jpiglo/2+1 ) THEN 325 startloop = 1 326 ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 327 startloop = jpiglo/2+1 - nimpp + 1 383 endloop = jpi - nn_hls 384 ENDIF 385 DO jl = 1, ipl; DO jk = 1, ipk 386 DO jj = 1, nn_hls 387 ijj = jpj -jj +1 388 DO ji = 1, endloop 389 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 390 ARRAY_IN(ji,ijj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 391 END DO 392 END DO 393 END DO; END DO 394 IF((nimpp + jpi - 1) .eq. jpiglo) THEN 395 DO jl = 1, ipl; DO jk = 1, ipk 396 DO jj = 1, nn_hls 397 ijj = jpj -jj +1 398 DO ii = 1, nn_hls 399 iij = jpi -ii+1 400 ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj-1,jk,jl,jf) 401 END DO 402 END DO 403 END DO; END DO 404 ENDIF 405 ! 406 IF ( .NOT. l_fast_exchanges ) THEN 407 IF( nimpp + jpi - 1 /= jpiglo ) THEN 408 endloop = jpi 409 ELSE 410 endloop = jpi - nn_hls 411 ENDIF 412 IF( nimpp >= Ni0glo/2+2 ) THEN 413 startloop = 1 414 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 415 startloop = Ni0glo/2+2 - nimpp + nn_hls 328 416 ELSE 329 417 startloop = endloop + 1 … … 332 420 DO jl = 1, ipl; DO jk = 1, ipk 333 421 DO ji = startloop, endloop 334 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 2335 ARRAY_IN(ji, nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)422 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 423 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 336 424 END DO 337 425 END DO; END DO … … 349 437 END DO ! End jf loop 350 438 END SUBROUTINE ROUTINE_NFD 439 #undef PRECISION 351 440 #undef ARRAY_TYPE 352 441 #undef ARRAY_IN -
utils/tools/DOMAINcfg/src/lbclnk.F90
r13204 r14623 7 7 !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module 8 8 !! 3.2 ! 2009-03 (R. Benshila) External north fold treatment 9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. 9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 10 10 !! 3.4 ! 2012-12 (R. Bourdalle-Badie, G. Reffray) add a C1D case 11 11 !! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi … … 14 14 !! - ! 2017-05 (G. Madec) create generic.h90 files to generate all lbc and north fold routines 15 15 !!---------------------------------------------------------------------- 16 #if defined key_mpp_mpi17 !!----------------------------------------------------------------------18 !! 'key_mpp_mpi' MPI massively parallel processing library19 !!----------------------------------------------------------------------20 16 !! define the generic interfaces of lib_mpp routines 21 17 !!---------------------------------------------------------------------- 22 18 !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 23 !!---------------------------------------------------------------------- 24 USE par_oce ! ocean dynamics and tracers 19 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 20 !!---------------------------------------------------------------------- 21 USE dom_oce ! ocean space and time domain 25 22 USE lib_mpp ! distributed memory computing library 26 23 USE lbcnfd ! north fold 24 USE in_out_manager ! I/O manager 25 26 IMPLICIT NONE 27 PRIVATE 27 28 28 29 INTERFACE lbc_lnk 29 MODULE PROCEDURE mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 30 MODULE PROCEDURE mpp_lnk_2d_sp , mpp_lnk_3d_sp , mpp_lnk_4d_sp 31 MODULE PROCEDURE mpp_lnk_2d_dp , mpp_lnk_3d_dp , mpp_lnk_4d_dp 30 32 END INTERFACE 31 33 INTERFACE lbc_lnk_ptr 32 MODULE PROCEDURE mpp_lnk_2d_ptr , mpp_lnk_3d_ptr , mpp_lnk_4d_ptr 34 MODULE PROCEDURE mpp_lnk_2d_ptr_sp , mpp_lnk_3d_ptr_sp , mpp_lnk_4d_ptr_sp 35 MODULE PROCEDURE mpp_lnk_2d_ptr_dp , mpp_lnk_3d_ptr_dp , mpp_lnk_4d_ptr_dp 33 36 END INTERFACE 34 37 INTERFACE lbc_lnk_multi 35 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 38 MODULE PROCEDURE lbc_lnk_2d_multi_sp , lbc_lnk_3d_multi_sp, lbc_lnk_4d_multi_sp 39 MODULE PROCEDURE lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 36 40 END INTERFACE 37 41 ! 38 42 INTERFACE lbc_lnk_icb 39 MODULE PROCEDURE mpp_lnk_2d_icb 43 MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp 44 END INTERFACE 45 46 INTERFACE mpp_nfd 47 MODULE PROCEDURE mpp_nfd_2d_sp , mpp_nfd_3d_sp , mpp_nfd_4d_sp 48 MODULE PROCEDURE mpp_nfd_2d_dp , mpp_nfd_3d_dp , mpp_nfd_4d_dp 49 MODULE PROCEDURE mpp_nfd_2d_ptr_sp, mpp_nfd_3d_ptr_sp, mpp_nfd_4d_ptr_sp 50 MODULE PROCEDURE mpp_nfd_2d_ptr_dp, mpp_nfd_3d_ptr_dp, mpp_nfd_4d_ptr_dp 51 40 52 END INTERFACE 41 53 … … 44 56 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 45 57 58 #if defined key_mpp_mpi 59 !$AGRIF_DO_NOT_TREAT 60 INCLUDE 'mpif.h' 61 !$AGRIF_END_DO_NOT_TREAT 62 #endif 63 64 INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 1 65 INTEGER, PUBLIC, PARAMETER :: jpfillcst = 2 66 INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 3 67 INTEGER, PUBLIC, PARAMETER :: jpfillperio = 4 68 INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 5 69 70 !! * Substitutions 71 # include "do_loop_substitute.h90" 46 72 !!---------------------------------------------------------------------- 47 73 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 48 !! $Id: lbclnk.F90 1 0425 2018-12-19 21:54:16Z smasson$74 !! $Id: lbclnk.F90 13226 2020-07-02 14:24:31Z orioltp $ 49 75 !! Software governed by the CeCILL license (see ./LICENSE) 50 76 !!---------------------------------------------------------------------- 51 77 CONTAINS 52 53 #else54 !!----------------------------------------------------------------------55 !! Default option shared memory computing56 !!----------------------------------------------------------------------57 !! routines setting the appropriate values58 !! on first and last row and column of the global domain59 !!----------------------------------------------------------------------60 !! lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh61 !! lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh62 !! lbc_lnk : generic interface for lbc_lnk_3d and lbc_lnk_2d63 !! lbc_lnk_3d : set the lateral boundary condition on a 3D variable on ocean mesh64 !! lbc_lnk_2d : set the lateral boundary condition on a 2D variable on ocean mesh65 !!----------------------------------------------------------------------66 USE dom_oce ! ocean space and time domain67 USE in_out_manager ! I/O manager68 USE lbcnfd ! north fold69 70 IMPLICIT NONE71 PRIVATE72 73 INTERFACE lbc_lnk74 MODULE PROCEDURE lbc_lnk_2d , lbc_lnk_3d , lbc_lnk_4d75 END INTERFACE76 INTERFACE lbc_lnk_ptr77 MODULE PROCEDURE lbc_lnk_2d_ptr , lbc_lnk_3d_ptr , lbc_lnk_4d_ptr78 END INTERFACE79 INTERFACE lbc_lnk_multi80 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi81 END INTERFACE82 !83 INTERFACE lbc_lnk_icb84 MODULE PROCEDURE lbc_lnk_2d_icb85 END INTERFACE86 87 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions88 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions89 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions90 91 !!----------------------------------------------------------------------92 !! NEMO/OCE 4.0 , NEMO Consortium (2018)93 !! $Id: lbclnk.F90 10425 2018-12-19 21:54:16Z smasson $94 !! Software governed by the CeCILL license (see ./LICENSE)95 !!----------------------------------------------------------------------96 CONTAINS97 98 !!======================================================================99 !! Default option 3D shared memory computing100 !!======================================================================101 !! routines setting land point, or east-west cyclic,102 !! or north-south cyclic, or north fold values103 !! on first and last row and column of the global domain104 !!----------------------------------------------------------------------105 106 !!----------------------------------------------------------------------107 !! *** routine lbc_lnk_(2,3,4)d ***108 !!109 !! * Argument : dummy argument use in lbc_lnk_... routines110 !! ptab : array or pointer of arrays on which the boundary condition is applied111 !! cd_nat : nature of array grid-points112 !! psgn : sign used across the north fold boundary113 !! kfld : optional, number of pt3d arrays114 !! cd_mpp : optional, fill the overlap area only115 !! pval : optional, background value (used at closed boundaries)116 !!----------------------------------------------------------------------117 !118 ! !== 2D array and array of 2D pointer ==!119 !120 # define DIM_2d121 # define ROUTINE_LNK lbc_lnk_2d122 # include "lbc_lnk_generic.h90"123 # undef ROUTINE_LNK124 # define MULTI125 # define ROUTINE_LNK lbc_lnk_2d_ptr126 # include "lbc_lnk_generic.h90"127 # undef ROUTINE_LNK128 # undef MULTI129 # undef DIM_2d130 !131 ! !== 3D array and array of 3D pointer ==!132 !133 # define DIM_3d134 # define ROUTINE_LNK lbc_lnk_3d135 # include "lbc_lnk_generic.h90"136 # undef ROUTINE_LNK137 # define MULTI138 # define ROUTINE_LNK lbc_lnk_3d_ptr139 # include "lbc_lnk_generic.h90"140 # undef ROUTINE_LNK141 # undef MULTI142 # undef DIM_3d143 !144 ! !== 4D array and array of 4D pointer ==!145 !146 # define DIM_4d147 # define ROUTINE_LNK lbc_lnk_4d148 # include "lbc_lnk_generic.h90"149 # undef ROUTINE_LNK150 # define MULTI151 # define ROUTINE_LNK lbc_lnk_4d_ptr152 # include "lbc_lnk_generic.h90"153 # undef ROUTINE_LNK154 # undef MULTI155 # undef DIM_4d156 157 !!======================================================================158 !! identical routines in both C1D and shared memory computing159 !!======================================================================160 161 !!----------------------------------------------------------------------162 163 !!gm This routine should be removed with an optional halos size added in argument of generic routines164 165 SUBROUTINE lbc_lnk_2d_icb( cdname, pt2d, cd_type, psgn, ki, kj )166 !!----------------------------------------------------------------------167 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine168 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied169 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points170 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold171 INTEGER , INTENT(in ) :: ki, kj ! sizes of extra halo (not needed in non-mpp)172 !!----------------------------------------------------------------------173 CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn )174 END SUBROUTINE lbc_lnk_2d_icb175 !!gm end176 177 #endif178 179 !!======================================================================180 !! identical routines in both distributed and shared memory computing181 !!======================================================================182 78 183 79 !!---------------------------------------------------------------------- … … 202 98 !!---------------------------------------------------------------------- 203 99 204 # define DIM_2d 205 # define ROUTINE_MULTI lbc_lnk_2d_multi 206 # define ROUTINE_LOAD load_ptr_2d 207 # include "lbc_lnk_multi_generic.h90" 208 # undef ROUTINE_MULTI 209 # undef ROUTINE_LOAD 210 # undef DIM_2d 211 212 213 # define DIM_3d 214 # define ROUTINE_MULTI lbc_lnk_3d_multi 215 # define ROUTINE_LOAD load_ptr_3d 216 # include "lbc_lnk_multi_generic.h90" 217 # undef ROUTINE_MULTI 218 # undef ROUTINE_LOAD 219 # undef DIM_3d 220 221 222 # define DIM_4d 223 # define ROUTINE_MULTI lbc_lnk_4d_multi 224 # define ROUTINE_LOAD load_ptr_4d 225 # include "lbc_lnk_multi_generic.h90" 226 # undef ROUTINE_MULTI 227 # undef ROUTINE_LOAD 100 !! 101 !! ---- SINGLE PRECISION VERSIONS 102 !! 103 # define SINGLE_PRECISION 104 # define DIM_2d 105 # define ROUTINE_LOAD load_ptr_2d_sp 106 # define ROUTINE_MULTI lbc_lnk_2d_multi_sp 107 # include "lbc_lnk_multi_generic.h90" 108 # undef ROUTINE_MULTI 109 # undef ROUTINE_LOAD 110 # undef DIM_2d 111 112 # define DIM_3d 113 # define ROUTINE_LOAD load_ptr_3d_sp 114 # define ROUTINE_MULTI lbc_lnk_3d_multi_sp 115 # include "lbc_lnk_multi_generic.h90" 116 # undef ROUTINE_MULTI 117 # undef ROUTINE_LOAD 118 # undef DIM_3d 119 120 # define DIM_4d 121 # define ROUTINE_LOAD load_ptr_4d_sp 122 # define ROUTINE_MULTI lbc_lnk_4d_multi_sp 123 # include "lbc_lnk_multi_generic.h90" 124 # undef ROUTINE_MULTI 125 # undef ROUTINE_LOAD 126 # undef DIM_4d 127 # undef SINGLE_PRECISION 128 !! 129 !! ---- DOUBLE PRECISION VERSIONS 130 !! 131 132 # define DIM_2d 133 # define ROUTINE_LOAD load_ptr_2d_dp 134 # define ROUTINE_MULTI lbc_lnk_2d_multi_dp 135 # include "lbc_lnk_multi_generic.h90" 136 # undef ROUTINE_MULTI 137 # undef ROUTINE_LOAD 138 # undef DIM_2d 139 140 # define DIM_3d 141 # define ROUTINE_LOAD load_ptr_3d_dp 142 # define ROUTINE_MULTI lbc_lnk_3d_multi_dp 143 # include "lbc_lnk_multi_generic.h90" 144 # undef ROUTINE_MULTI 145 # undef ROUTINE_LOAD 146 # undef DIM_3d 147 148 # define DIM_4d 149 # define ROUTINE_LOAD load_ptr_4d_dp 150 # define ROUTINE_MULTI lbc_lnk_4d_multi_dp 151 # include "lbc_lnk_multi_generic.h90" 152 # undef ROUTINE_MULTI 153 # undef ROUTINE_LOAD 154 # undef DIM_4d 155 156 !!---------------------------------------------------------------------- 157 !! *** routine mpp_lnk_(2,3,4)d *** 158 !! 159 !! * Argument : dummy argument use in mpp_lnk_... routines 160 !! ptab : array or pointer of arrays on which the boundary condition is applied 161 !! cd_nat : nature of array grid-points 162 !! psgn : sign used across the north fold boundary 163 !! kfld : optional, number of pt3d arrays 164 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 165 !! pfillval : optional, background value (used with jpfillcopy) 166 !!---------------------------------------------------------------------- 167 ! 168 ! !== 2D array and array of 2D pointer ==! 169 ! 170 !! 171 !! ---- SINGLE PRECISION VERSIONS 172 !! 173 # define SINGLE_PRECISION 174 # define DIM_2d 175 # define ROUTINE_LNK mpp_lnk_2d_sp 176 # include "mpp_lnk_generic.h90" 177 # undef ROUTINE_LNK 178 # define MULTI 179 # define ROUTINE_LNK mpp_lnk_2d_ptr_sp 180 # include "mpp_lnk_generic.h90" 181 # undef ROUTINE_LNK 182 # undef MULTI 183 # undef DIM_2d 184 ! 185 ! !== 3D array and array of 3D pointer ==! 186 ! 187 # define DIM_3d 188 # define ROUTINE_LNK mpp_lnk_3d_sp 189 # include "mpp_lnk_generic.h90" 190 # undef ROUTINE_LNK 191 # define MULTI 192 # define ROUTINE_LNK mpp_lnk_3d_ptr_sp 193 # include "mpp_lnk_generic.h90" 194 # undef ROUTINE_LNK 195 # undef MULTI 196 # undef DIM_3d 197 ! 198 ! !== 4D array and array of 4D pointer ==! 199 ! 200 # define DIM_4d 201 # define ROUTINE_LNK mpp_lnk_4d_sp 202 # include "mpp_lnk_generic.h90" 203 # undef ROUTINE_LNK 204 # define MULTI 205 # define ROUTINE_LNK mpp_lnk_4d_ptr_sp 206 # include "mpp_lnk_generic.h90" 207 # undef ROUTINE_LNK 208 # undef MULTI 209 # undef DIM_4d 210 # undef SINGLE_PRECISION 211 212 !! 213 !! ---- DOUBLE PRECISION VERSIONS 214 !! 215 # define DIM_2d 216 # define ROUTINE_LNK mpp_lnk_2d_dp 217 # include "mpp_lnk_generic.h90" 218 # undef ROUTINE_LNK 219 # define MULTI 220 # define ROUTINE_LNK mpp_lnk_2d_ptr_dp 221 # include "mpp_lnk_generic.h90" 222 # undef ROUTINE_LNK 223 # undef MULTI 224 # undef DIM_2d 225 ! 226 ! !== 3D array and array of 3D pointer ==! 227 ! 228 # define DIM_3d 229 # define ROUTINE_LNK mpp_lnk_3d_dp 230 # include "mpp_lnk_generic.h90" 231 # undef ROUTINE_LNK 232 # define MULTI 233 # define ROUTINE_LNK mpp_lnk_3d_ptr_dp 234 # include "mpp_lnk_generic.h90" 235 # undef ROUTINE_LNK 236 # undef MULTI 237 # undef DIM_3d 238 ! 239 ! !== 4D array and array of 4D pointer ==! 240 ! 241 # define DIM_4d 242 # define ROUTINE_LNK mpp_lnk_4d_dp 243 # include "mpp_lnk_generic.h90" 244 # undef ROUTINE_LNK 245 # define MULTI 246 # define ROUTINE_LNK mpp_lnk_4d_ptr_dp 247 # include "mpp_lnk_generic.h90" 248 # undef ROUTINE_LNK 249 # undef MULTI 250 # undef DIM_4d 251 252 253 !!---------------------------------------------------------------------- 254 !! *** routine mpp_nfd_(2,3,4)d *** 255 !! 256 !! * Argument : dummy argument use in mpp_nfd_... routines 257 !! ptab : array or pointer of arrays on which the boundary condition is applied 258 !! cd_nat : nature of array grid-points 259 !! psgn : sign used across the north fold boundary 260 !! kfld : optional, number of pt3d arrays 261 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 262 !! pfillval : optional, background value (used with jpfillcopy) 263 !!---------------------------------------------------------------------- 264 ! 265 ! !== 2D array and array of 2D pointer ==! 266 ! 267 !! 268 !! ---- SINGLE PRECISION VERSIONS 269 !! 270 # define SINGLE_PRECISION 271 # define DIM_2d 272 # define ROUTINE_NFD mpp_nfd_2d_sp 273 # include "mpp_nfd_generic.h90" 274 # undef ROUTINE_NFD 275 # define MULTI 276 # define ROUTINE_NFD mpp_nfd_2d_ptr_sp 277 # include "mpp_nfd_generic.h90" 278 # undef ROUTINE_NFD 279 # undef MULTI 280 # undef DIM_2d 281 ! 282 ! !== 3D array and array of 3D pointer ==! 283 ! 284 # define DIM_3d 285 # define ROUTINE_NFD mpp_nfd_3d_sp 286 # include "mpp_nfd_generic.h90" 287 # undef ROUTINE_NFD 288 # define MULTI 289 # define ROUTINE_NFD mpp_nfd_3d_ptr_sp 290 # include "mpp_nfd_generic.h90" 291 # undef ROUTINE_NFD 292 # undef MULTI 293 # undef DIM_3d 294 ! 295 ! !== 4D array and array of 4D pointer ==! 296 ! 297 # define DIM_4d 298 # define ROUTINE_NFD mpp_nfd_4d_sp 299 # include "mpp_nfd_generic.h90" 300 # undef ROUTINE_NFD 301 # define MULTI 302 # define ROUTINE_NFD mpp_nfd_4d_ptr_sp 303 # include "mpp_nfd_generic.h90" 304 # undef ROUTINE_NFD 305 # undef MULTI 306 # undef DIM_4d 307 # undef SINGLE_PRECISION 308 309 !! 310 !! ---- DOUBLE PRECISION VERSIONS 311 !! 312 # define DIM_2d 313 # define ROUTINE_NFD mpp_nfd_2d_dp 314 # include "mpp_nfd_generic.h90" 315 # undef ROUTINE_NFD 316 # define MULTI 317 # define ROUTINE_NFD mpp_nfd_2d_ptr_dp 318 # include "mpp_nfd_generic.h90" 319 # undef ROUTINE_NFD 320 # undef MULTI 321 # undef DIM_2d 322 ! 323 ! !== 3D array and array of 3D pointer ==! 324 ! 325 # define DIM_3d 326 # define ROUTINE_NFD mpp_nfd_3d_dp 327 # include "mpp_nfd_generic.h90" 328 # undef ROUTINE_NFD 329 # define MULTI 330 # define ROUTINE_NFD mpp_nfd_3d_ptr_dp 331 # include "mpp_nfd_generic.h90" 332 # undef ROUTINE_NFD 333 # undef MULTI 334 # undef DIM_3d 335 ! 336 ! !== 4D array and array of 4D pointer ==! 337 ! 338 # define DIM_4d 339 # define ROUTINE_NFD mpp_nfd_4d_dp 340 # include "mpp_nfd_generic.h90" 341 # undef ROUTINE_NFD 342 # define MULTI 343 # define ROUTINE_NFD mpp_nfd_4d_ptr_dp 344 # include "mpp_nfd_generic.h90" 345 # undef ROUTINE_NFD 346 # undef MULTI 228 347 # undef DIM_4d 229 348 230 349 !!====================================================================== 350 351 352 !!====================================================================== 353 !!--------------------------------------------------------------------- 354 !! *** routine mpp_lbc_north_icb *** 355 !! 356 !! ** Purpose : Ensure proper north fold horizontal bondary condition 357 !! in mpp configuration in case of jpn1 > 1 and for 2d 358 !! array with outer extra halo 359 !! 360 !! ** Method : North fold condition and mpp with more than one proc 361 !! in i-direction require a specific treatment. We gather 362 !! the 4+kextj northern lines of the global domain on 1 363 !! processor and apply lbc north-fold on this sub array. 364 !! Then we scatter the north fold array back to the processors. 365 !! This routine accounts for an extra halo with icebergs 366 !! and assumes ghost rows and columns have been suppressed. 367 !! 368 !!---------------------------------------------------------------------- 369 # define SINGLE_PRECISION 370 # define ROUTINE_LNK mpp_lbc_north_icb_sp 371 # include "mpp_lbc_north_icb_generic.h90" 372 # undef ROUTINE_LNK 373 # undef SINGLE_PRECISION 374 # define ROUTINE_LNK mpp_lbc_north_icb_dp 375 # include "mpp_lbc_north_icb_generic.h90" 376 # undef ROUTINE_LNK 377 378 379 !!---------------------------------------------------------------------- 380 !! *** routine mpp_lnk_2d_icb *** 381 !! 382 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) 383 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 384 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 385 !! 386 !! ** Method : Use mppsend and mpprecv function for passing mask 387 !! between processors following neighboring subdomains. 388 !! domain parameters 389 !! jpi : first dimension of the local subdomain 390 !! jpj : second dimension of the local subdomain 391 !! kexti : number of columns for extra outer halo 392 !! kextj : number of rows for extra outer halo 393 !! nbondi : mark for "east-west local boundary" 394 !! nbondj : mark for "north-south local boundary" 395 !! noea : number for local neighboring processors 396 !! nowe : number for local neighboring processors 397 !! noso : number for local neighboring processors 398 !! nono : number for local neighboring processors 399 !!---------------------------------------------------------------------- 400 401 # define SINGLE_PRECISION 402 # define ROUTINE_LNK mpp_lnk_2d_icb_sp 403 # include "mpp_lnk_icb_generic.h90" 404 # undef ROUTINE_LNK 405 # undef SINGLE_PRECISION 406 # define ROUTINE_LNK mpp_lnk_2d_icb_dp 407 # include "mpp_lnk_icb_generic.h90" 408 # undef ROUTINE_LNK 409 231 410 END MODULE lbclnk 232 411 -
utils/tools/DOMAINcfg/src/lbcnfd.F90
r12414 r14623 20 20 USE dom_oce ! ocean space and time domain 21 21 USE in_out_manager ! I/O manager 22 USE lib_mpp ! MPP library 22 23 23 24 IMPLICIT NONE … … 25 26 26 27 INTERFACE lbc_nfd 27 MODULE PROCEDURE lbc_nfd_2d , lbc_nfd_3d , lbc_nfd_4d 28 MODULE PROCEDURE lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 29 MODULE PROCEDURE lbc_nfd_2d_ext 28 MODULE PROCEDURE lbc_nfd_2d_sp , lbc_nfd_3d_sp , lbc_nfd_4d_sp 29 MODULE PROCEDURE lbc_nfd_2d_ptr_sp, lbc_nfd_3d_ptr_sp, lbc_nfd_4d_ptr_sp 30 MODULE PROCEDURE lbc_nfd_2d_ext_sp 31 MODULE PROCEDURE lbc_nfd_2d_dp , lbc_nfd_3d_dp , lbc_nfd_4d_dp 32 MODULE PROCEDURE lbc_nfd_2d_ptr_dp, lbc_nfd_3d_ptr_dp, lbc_nfd_4d_ptr_dp 33 MODULE PROCEDURE lbc_nfd_2d_ext_dp 30 34 END INTERFACE 31 35 ! 32 36 INTERFACE lbc_nfd_nogather 33 37 ! ! Currently only 4d array version is needed 34 MODULE PROCEDURE lbc_nfd_nogather_2d , lbc_nfd_nogather_3d 35 MODULE PROCEDURE lbc_nfd_nogather_4d 36 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 38 MODULE PROCEDURE lbc_nfd_nogather_2d_sp , lbc_nfd_nogather_3d_sp 39 MODULE PROCEDURE lbc_nfd_nogather_4d_sp 40 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_sp, lbc_nfd_nogather_3d_ptr_sp 41 MODULE PROCEDURE lbc_nfd_nogather_2d_dp , lbc_nfd_nogather_3d_dp 42 MODULE PROCEDURE lbc_nfd_nogather_4d_dp 43 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_dp, lbc_nfd_nogather_3d_ptr_dp 37 44 ! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr 38 45 END INTERFACE 39 46 40 TYPE, PUBLIC :: PTR_2D !: array of 2D pointers (also used in lib_mpp) 41 REAL(wp), DIMENSION (:,:) , POINTER :: pt2d 42 END TYPE PTR_2D 43 TYPE, PUBLIC :: PTR_3D !: array of 3D pointers (also used in lib_mpp) 44 REAL(wp), DIMENSION (:,:,:) , POINTER :: pt3d 45 END TYPE PTR_3D 46 TYPE, PUBLIC :: PTR_4D !: array of 4D pointers (also used in lib_mpp) 47 REAL(wp), DIMENSION (:,:,:,:), POINTER :: pt4d 48 END TYPE PTR_4D 47 TYPE, PUBLIC :: PTR_2D_dp !: array of 2D pointers (also used in lib_mpp) 48 REAL(dp), DIMENSION (:,:) , POINTER :: pt2d 49 END TYPE PTR_2D_dp 50 TYPE, PUBLIC :: PTR_3D_dp !: array of 3D pointers (also used in lib_mpp) 51 REAL(dp), DIMENSION (:,:,:) , POINTER :: pt3d 52 END TYPE PTR_3D_dp 53 TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (also used in lib_mpp) 54 REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d 55 END TYPE PTR_4D_dp 56 57 TYPE, PUBLIC :: PTR_2D_sp !: array of 2D pointers (also used in lib_mpp) 58 REAL(sp), DIMENSION (:,:) , POINTER :: pt2d 59 END TYPE PTR_2D_sp 60 TYPE, PUBLIC :: PTR_3D_sp !: array of 3D pointers (also used in lib_mpp) 61 REAL(sp), DIMENSION (:,:,:) , POINTER :: pt3d 62 END TYPE PTR_3D_sp 63 TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (also used in lib_mpp) 64 REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d 65 END TYPE PTR_4D_sp 66 49 67 50 68 PUBLIC lbc_nfd ! north fold conditions … … 52 70 53 71 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 !: 54 INTEGER, PUBLIC :: nsndto , nfsloop, nfeloop!:72 INTEGER, PUBLIC :: nsndto !: 55 73 INTEGER, PUBLIC, DIMENSION (jpmaxngh) :: isendto !: processes to which communicate 74 INTEGER, PUBLIC :: ijpj 56 75 57 76 !!---------------------------------------------------------------------- 58 77 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 59 !! $Id: lbcnfd.F90 1 0425 2018-12-19 21:54:16Z smasson $78 !! $Id: lbcnfd.F90 13286 2020-07-09 15:48:29Z smasson $ 60 79 !! Software governed by the CeCILL license (see ./LICENSE) 61 80 !!---------------------------------------------------------------------- … … 74 93 !!---------------------------------------------------------------------- 75 94 ! 76 ! !== 2D array and array of 2D pointer ==! 77 ! 78 # define DIM_2d 79 # define ROUTINE_NFD lbc_nfd_2d 80 # include "lbc_nfd_generic.h90" 81 # undef ROUTINE_NFD 82 # define MULTI 83 # define ROUTINE_NFD lbc_nfd_2d_ptr 95 ! !== SINGLE PRECISION VERSIONS 96 ! 97 ! 98 ! !== 2D array and array of 2D pointer ==! 99 ! 100 # define SINGLE_PRECISION 101 # define DIM_2d 102 # define ROUTINE_NFD lbc_nfd_2d_sp 103 # include "lbc_nfd_generic.h90" 104 # undef ROUTINE_NFD 105 # define MULTI 106 # define ROUTINE_NFD lbc_nfd_2d_ptr_sp 84 107 # include "lbc_nfd_generic.h90" 85 108 # undef ROUTINE_NFD … … 90 113 ! 91 114 # define DIM_2d 92 # define ROUTINE_NFD lbc_nfd_2d_ext 115 # define ROUTINE_NFD lbc_nfd_2d_ext_sp 93 116 # include "lbc_nfd_ext_generic.h90" 94 117 # undef ROUTINE_NFD … … 98 121 ! 99 122 # define DIM_3d 100 # define ROUTINE_NFD lbc_nfd_3d 101 # include "lbc_nfd_generic.h90" 102 # undef ROUTINE_NFD 103 # define MULTI 104 # define ROUTINE_NFD lbc_nfd_3d_ptr 105 # include "lbc_nfd_generic.h90" 106 # undef ROUTINE_NFD 107 # undef MULTI 108 # undef DIM_3d 109 ! 110 ! !== 4D array and array of 4D pointer ==! 111 ! 112 # define DIM_4d 113 # define ROUTINE_NFD lbc_nfd_4d 114 # include "lbc_nfd_generic.h90" 115 # undef ROUTINE_NFD 116 # define MULTI 117 # define ROUTINE_NFD lbc_nfd_4d_ptr 123 # define ROUTINE_NFD lbc_nfd_3d_sp 124 # include "lbc_nfd_generic.h90" 125 # undef ROUTINE_NFD 126 # define MULTI 127 # define ROUTINE_NFD lbc_nfd_3d_ptr_sp 128 # include "lbc_nfd_generic.h90" 129 # undef ROUTINE_NFD 130 # undef MULTI 131 # undef DIM_3d 132 ! 133 ! !== 4D array and array of 4D pointer ==! 134 ! 135 # define DIM_4d 136 # define ROUTINE_NFD lbc_nfd_4d_sp 137 # include "lbc_nfd_generic.h90" 138 # undef ROUTINE_NFD 139 # define MULTI 140 # define ROUTINE_NFD lbc_nfd_4d_ptr_sp 118 141 # include "lbc_nfd_generic.h90" 119 142 # undef ROUTINE_NFD … … 126 149 ! 127 150 # define DIM_2d 128 # define ROUTINE_NFD lbc_nfd_nogather_2d 129 # include "lbc_nfd_nogather_generic.h90" 130 # undef ROUTINE_NFD 131 # define MULTI 132 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr 133 # include "lbc_nfd_nogather_generic.h90" 134 # undef ROUTINE_NFD 135 # undef MULTI 136 # undef DIM_2d 137 ! 138 ! !== 3D array and array of 3D pointer ==! 139 ! 140 # define DIM_3d 141 # define ROUTINE_NFD lbc_nfd_nogather_3d 142 # include "lbc_nfd_nogather_generic.h90" 143 # undef ROUTINE_NFD 144 # define MULTI 145 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr 146 # include "lbc_nfd_nogather_generic.h90" 147 # undef ROUTINE_NFD 148 # undef MULTI 149 # undef DIM_3d 150 ! 151 ! !== 4D array and array of 4D pointer ==! 152 ! 153 # define DIM_4d 154 # define ROUTINE_NFD lbc_nfd_nogather_4d 151 # define ROUTINE_NFD lbc_nfd_nogather_2d_sp 152 # include "lbc_nfd_nogather_generic.h90" 153 # undef ROUTINE_NFD 154 # define MULTI 155 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_sp 156 # include "lbc_nfd_nogather_generic.h90" 157 # undef ROUTINE_NFD 158 # undef MULTI 159 # undef DIM_2d 160 ! 161 ! !== 3D array and array of 3D pointer ==! 162 ! 163 # define DIM_3d 164 # define ROUTINE_NFD lbc_nfd_nogather_3d_sp 165 # include "lbc_nfd_nogather_generic.h90" 166 # undef ROUTINE_NFD 167 # define MULTI 168 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_sp 169 # include "lbc_nfd_nogather_generic.h90" 170 # undef ROUTINE_NFD 171 # undef MULTI 172 # undef DIM_3d 173 ! 174 ! !== 4D array and array of 4D pointer ==! 175 ! 176 # define DIM_4d 177 # define ROUTINE_NFD lbc_nfd_nogather_4d_sp 155 178 # include "lbc_nfd_nogather_generic.h90" 156 179 # undef ROUTINE_NFD … … 161 184 !# undef MULTI 162 185 # undef DIM_4d 163 164 !!---------------------------------------------------------------------- 186 # undef SINGLE_PRECISION 187 188 !!---------------------------------------------------------------------- 189 ! 190 ! !== DOUBLE PRECISION VERSIONS 191 ! 192 ! 193 ! !== 2D array and array of 2D pointer ==! 194 ! 195 # define DIM_2d 196 # define ROUTINE_NFD lbc_nfd_2d_dp 197 # include "lbc_nfd_generic.h90" 198 # undef ROUTINE_NFD 199 # define MULTI 200 # define ROUTINE_NFD lbc_nfd_2d_ptr_dp 201 # include "lbc_nfd_generic.h90" 202 # undef ROUTINE_NFD 203 # undef MULTI 204 # undef DIM_2d 205 ! 206 ! !== 2D array with extra haloes ==! 207 ! 208 # define DIM_2d 209 # define ROUTINE_NFD lbc_nfd_2d_ext_dp 210 # include "lbc_nfd_ext_generic.h90" 211 # undef ROUTINE_NFD 212 # undef DIM_2d 213 ! 214 ! !== 3D array and array of 3D pointer ==! 215 ! 216 # define DIM_3d 217 # define ROUTINE_NFD lbc_nfd_3d_dp 218 # include "lbc_nfd_generic.h90" 219 # undef ROUTINE_NFD 220 # define MULTI 221 # define ROUTINE_NFD lbc_nfd_3d_ptr_dp 222 # include "lbc_nfd_generic.h90" 223 # undef ROUTINE_NFD 224 # undef MULTI 225 # undef DIM_3d 226 ! 227 ! !== 4D array and array of 4D pointer ==! 228 ! 229 # define DIM_4d 230 # define ROUTINE_NFD lbc_nfd_4d_dp 231 # include "lbc_nfd_generic.h90" 232 # undef ROUTINE_NFD 233 # define MULTI 234 # define ROUTINE_NFD lbc_nfd_4d_ptr_dp 235 # include "lbc_nfd_generic.h90" 236 # undef ROUTINE_NFD 237 # undef MULTI 238 # undef DIM_4d 239 ! 240 ! lbc_nfd_nogather routines 241 ! 242 ! !== 2D array and array of 2D pointer ==! 243 ! 244 # define DIM_2d 245 # define ROUTINE_NFD lbc_nfd_nogather_2d_dp 246 # include "lbc_nfd_nogather_generic.h90" 247 # undef ROUTINE_NFD 248 # define MULTI 249 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_dp 250 # include "lbc_nfd_nogather_generic.h90" 251 # undef ROUTINE_NFD 252 # undef MULTI 253 # undef DIM_2d 254 ! 255 ! !== 3D array and array of 3D pointer ==! 256 ! 257 # define DIM_3d 258 # define ROUTINE_NFD lbc_nfd_nogather_3d_dp 259 # include "lbc_nfd_nogather_generic.h90" 260 # undef ROUTINE_NFD 261 # define MULTI 262 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_dp 263 # include "lbc_nfd_nogather_generic.h90" 264 # undef ROUTINE_NFD 265 # undef MULTI 266 # undef DIM_3d 267 ! 268 ! !== 4D array and array of 4D pointer ==! 269 ! 270 # define DIM_4d 271 # define ROUTINE_NFD lbc_nfd_nogather_4d_dp 272 # include "lbc_nfd_nogather_generic.h90" 273 # undef ROUTINE_NFD 274 !# define MULTI 275 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr 276 !# include "lbc_nfd_nogather_generic.h90" 277 !# undef ROUTINE_NFD 278 !# undef MULTI 279 # undef DIM_4d 280 281 !!---------------------------------------------------------------------- 282 165 283 166 284 -
utils/tools/DOMAINcfg/src/lib_fortran.F90
r12414 r14623 63 63 #endif 64 64 65 !! * Substitutions 66 # include "do_loop_substitute.h90" 65 67 !!---------------------------------------------------------------------- 66 68 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 67 !! $Id: lib_fortran.F90 1 0425 2018-12-19 21:54:16Z smasson$69 !! $Id: lib_fortran.F90 13295 2020-07-10 18:24:21Z acc $ 68 70 !! Software governed by the CeCILL license (see ./LICENSE) 69 71 !!---------------------------------------------------------------------- … … 141 143 !!---------------------------------------------------------------------- 142 144 REAL(wp), INTENT(in ) :: ptab(:,:) ! array on which operation is applied 143 COMPLEX( wp) :: local_sum_2d144 ! 145 !!----------------------------------------------------------------------- 146 ! 147 COMPLEX( wp):: ctmp145 COMPLEX(dp) :: local_sum_2d 146 ! 147 !!----------------------------------------------------------------------- 148 ! 149 COMPLEX(dp):: ctmp 148 150 REAL(wp) :: ztmp 149 151 INTEGER :: ji, jj ! dummy loop indices … … 159 161 DO ji = 1, ipi 160 162 ztmp = ptab(ji,jj) * tmask_i(ji,jj) 161 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )163 CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) 162 164 END DO 163 165 END DO … … 170 172 !!---------------------------------------------------------------------- 171 173 REAL(wp), INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied 172 COMPLEX( wp) :: local_sum_3d173 ! 174 !!----------------------------------------------------------------------- 175 ! 176 COMPLEX( wp):: ctmp174 COMPLEX(dp) :: local_sum_3d 175 ! 176 !!----------------------------------------------------------------------- 177 ! 178 COMPLEX(dp):: ctmp 177 179 REAL(wp) :: ztmp 178 180 INTEGER :: ji, jj, jk ! dummy loop indices … … 190 192 DO ji = 1, ipi 191 193 ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) 192 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )194 CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) 193 195 END DO 194 196 END DO … … 215 217 IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' ) 216 218 ! 217 DO jj = 1, jpj 218 DO ji = 1, jpi 219 DO_2D( 1, 1, 1, 1 ) 220 IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN ! bottom left corber of a 3x3 box 221 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box 222 jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box 223 IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain 224 p2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2)) 225 ENDIF 226 ENDIF 227 END_2D 228 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 229 IF( nbondi /= -1 ) THEN 230 IF( MOD(mig( 1), 3) == 1 ) p2d( 1,:) = p2d( 2,:) 231 IF( MOD(mig( 1), 3) == 2 ) p2d( 2,:) = p2d( 1,:) 232 ENDIF 233 IF( nbondi /= 1 ) THEN 234 IF( MOD(mig(jpi-2), 3) == 1 ) p2d( jpi,:) = p2d(jpi-1,:) 235 IF( MOD(mig(jpi-2), 3) == 0 ) p2d(jpi-1,:) = p2d( jpi,:) 236 ENDIF 237 IF( nbondj /= -1 ) THEN 238 IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2) 239 IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1) 240 ENDIF 241 IF( nbondj /= 1 ) THEN 242 IF( MOD(mjg(jpj-2), 3) == 1 ) p2d(:, jpj) = p2d(:,jpj-1) 243 IF( MOD(mjg(jpj-2), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj) 244 ENDIF 245 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 246 247 END SUBROUTINE sum3x3_2d 248 249 SUBROUTINE sum3x3_3d( p3d ) 250 !!----------------------------------------------------------------------- 251 !! *** routine sum3x3_3d *** 252 !! 253 !! ** Purpose : sum over 3x3 boxes 254 !!---------------------------------------------------------------------- 255 REAL(wp), DIMENSION (:,:,:), INTENT(inout) :: p3d 256 ! 257 INTEGER :: ji, ji2, jj, jj2, jn ! dummy loop indices 258 INTEGER :: ipn ! Third dimension size 259 !!---------------------------------------------------------------------- 260 ! 261 IF( SIZE(p3d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the first dimension is not equal to jpi' ) 262 IF( SIZE(p3d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the second dimension is not equal to jpj' ) 263 ipn = SIZE(p3d,3) 264 ! 265 DO jn = 1, ipn 266 DO_2D( 1, 1, 1, 1 ) 219 267 IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN ! bottom left corber of a 3x3 box 220 268 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box 221 269 jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box 222 270 IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain 223 p 2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2))271 p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn)) 224 272 ENDIF 225 273 ENDIF 226 END DO274 END_2D 227 275 END DO 228 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. ) 229 IF( nbondi /= -1 ) THEN 230 IF( MOD(mig( 1), 3) == 1 ) p2d( 1,:) = p2d( 2,:) 231 IF( MOD(mig( 1), 3) == 2 ) p2d( 2,:) = p2d( 1,:) 232 ENDIF 233 IF( nbondi /= 1 ) THEN 234 IF( MOD(mig(jpi-2), 3) == 1 ) p2d( jpi,:) = p2d(jpi-1,:) 235 IF( MOD(mig(jpi-2), 3) == 0 ) p2d(jpi-1,:) = p2d( jpi,:) 236 ENDIF 237 IF( nbondj /= -1 ) THEN 238 IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2) 239 IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1) 240 ENDIF 241 IF( nbondj /= 1 ) THEN 242 IF( MOD(mjg(jpj-2), 3) == 1 ) p2d(:, jpj) = p2d(:,jpj-1) 243 IF( MOD(mjg(jpj-2), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj) 244 ENDIF 245 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. ) 246 247 END SUBROUTINE sum3x3_2d 248 249 SUBROUTINE sum3x3_3d( p3d ) 250 !!----------------------------------------------------------------------- 251 !! *** routine sum3x3_3d *** 252 !! 253 !! ** Purpose : sum over 3x3 boxes 254 !!---------------------------------------------------------------------- 255 REAL(wp), DIMENSION (:,:,:), INTENT(inout) :: p3d 256 ! 257 INTEGER :: ji, ji2, jj, jj2, jn ! dummy loop indices 258 INTEGER :: ipn ! Third dimension size 259 !!---------------------------------------------------------------------- 260 ! 261 IF( SIZE(p3d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the first dimension is not equal to jpi' ) 262 IF( SIZE(p3d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the second dimension is not equal to jpj' ) 263 ipn = SIZE(p3d,3) 264 ! 265 DO jn = 1, ipn 266 DO jj = 1, jpj 267 DO ji = 1, jpi 268 IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN ! bottom left corber of a 3x3 box 269 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box 270 jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box 271 IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain 272 p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn)) 273 ENDIF 274 ENDIF 275 END DO 276 END DO 277 END DO 278 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. ) 276 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 279 277 IF( nbondi /= -1 ) THEN 280 278 IF( MOD(mig( 1), 3) == 1 ) p3d( 1,:,:) = p3d( 2,:,:) … … 293 291 IF( MOD(mjg(jpj-2), 3) == 0 ) p3d(:,jpj-1,:) = p3d(:, jpj,:) 294 292 ENDIF 295 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. )293 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 296 294 297 295 END SUBROUTINE sum3x3_3d … … 315 313 !! Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001 316 314 !!---------------------------------------------------------------------- 317 COMPLEX( wp), INTENT(in ) :: ydda318 COMPLEX( wp), INTENT(inout) :: yddb319 ! 320 REAL( wp) :: zerr, zt1, zt2 ! local work variables315 COMPLEX(dp), INTENT(in ) :: ydda 316 COMPLEX(dp), INTENT(inout) :: yddb 317 ! 318 REAL(dp) :: zerr, zt1, zt2 ! local work variables 321 319 !!----------------------------------------------------------------------- 322 320 ! -
utils/tools/DOMAINcfg/src/lib_fortran_generic.h90
r14199 r14623 40 40 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 41 41 !! 42 COMPLEX( wp):: ctmp42 COMPLEX(dp):: ctmp 43 43 REAL(wp) :: ztmp 44 44 INTEGER :: ji, jj, jk ! dummy loop indices … … 50 50 ipk = K_SIZE(ptab) ! 3rd dimension 51 51 ! 52 ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated52 ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated 53 53 54 54 DO jk = 1, ipk … … 56 56 DO ji = 1, ipi 57 57 ztmp = ARRAY_IN(ji,jj,jk) * MASK_ARRAY(ji,jj) 58 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )58 CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) 59 59 END DO 60 60 END DO … … 109 109 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 110 110 !! 111 COMPLEX( wp):: ctmp111 COMPLEX(dp):: ctmp 112 112 REAL(wp) :: ztmp 113 113 INTEGER :: jk ! dummy loop indices … … 117 117 ipk = K_SIZE(ptab) ! 3rd dimension 118 118 ! 119 ztmp = ARRAY_OPERATION( ARRAY_IN(:,:,1) )119 ztmp = ARRAY_OPERATION( ARRAY_IN(:,:,1)*tmask_i(:,:) ) 120 120 DO jk = 2, ipk 121 ztmp = SCALAR_OPERATION(ztmp, ARRAY_OPERATION( ARRAY_IN(:,:,jk) ))121 ztmp = SCALAR_OPERATION(ztmp, ARRAY_OPERATION( ARRAY_IN(:,:,jk)*tmask_i(:,:) )) 122 122 ENDDO 123 123 -
utils/tools/DOMAINcfg/src/lib_mpp.F90
r13204 r14623 19 19 !! 3.2 ! 2009 (O. Marti) add mpp_ini_znl 20 20 !! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager 21 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm. 21 22 !! 3.5 ! 2013 (C. Ethe, G. Madec) message passing arrays as local variables 22 23 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations … … 31 32 !! ctl_opn : Open file and check if required file is available. 32 33 !! ctl_nam : Prints informations when an error occurs while reading a namelist 33 !! get_unit : give the index of an unused logical unit 34 !!---------------------------------------------------------------------- 35 #if defined key_mpp_mpi 36 !!---------------------------------------------------------------------- 37 !! 'key_mpp_mpi' MPI massively parallel processing library 38 !!---------------------------------------------------------------------- 39 !! lib_mpp_alloc : allocate mpp arrays 40 !! mynode : indentify the processor unit 34 !! load_nml : Read, condense and buffer namelist file into character array for use as an internal file 35 !!---------------------------------------------------------------------- 36 !!---------------------------------------------------------------------- 37 !! mpp_start : get local communicator its size and rank 41 38 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 42 39 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) … … 54 51 !! mpp_ini_north : initialisation of north fold 55 52 !! mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs 53 !! mpp_bcast_nml : broadcast/receive namelist character buffer from reading process to all others 56 54 !!---------------------------------------------------------------------- 57 55 USE dom_oce ! ocean space and time domain 58 USE lbcnfd ! north fold treatment59 56 USE in_out_manager ! I/O manager 60 57 61 58 IMPLICIT NONE 62 59 PRIVATE 63 64 INTERFACE mpp_nfd65 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d66 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr67 END INTERFACE68 69 ! Interface associated to the mpp_lnk_... routines is defined in lbclnk70 PUBLIC mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d71 PUBLIC mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr72 60 ! 73 !!gm this should be useless 74 PUBLIC mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 75 PUBLIC mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 76 !!gm end 77 ! 78 PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 79 PUBLIC mynode, mppstop, mppsync, mpp_comm_free 61 PUBLIC ctl_stop, ctl_warn, ctl_opn, ctl_nam, load_nml 62 PUBLIC mpp_start, mppstop, mppsync, mpp_comm_free 80 63 PUBLIC mpp_ini_north 81 PUBLIC mpp_lnk_2d_icb82 PUBLIC mpp_lbc_north_icb83 64 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 84 65 PUBLIC mpp_delay_max, mpp_delay_sum, mpp_delay_rcv … … 86 67 PUBLIC mpp_ini_znl 87 68 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 69 PUBLIC mppsend_sp, mpprecv_sp ! needed by TAM and ICB routines 70 PUBLIC mppsend_dp, mpprecv_dp ! needed by TAM and ICB routines 71 PUBLIC mpp_report 72 PUBLIC mpp_bcast_nml 73 PUBLIC tic_tac 74 #if ! defined key_mpp_mpi 75 PUBLIC MPI_Wtime 76 #endif 88 77 89 78 !! * Interfaces … … 92 81 !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ 93 82 INTERFACE mpp_min 94 MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 83 MODULE PROCEDURE mppmin_a_int, mppmin_int 84 MODULE PROCEDURE mppmin_a_real_sp, mppmin_real_sp 85 MODULE PROCEDURE mppmin_a_real_dp, mppmin_real_dp 95 86 END INTERFACE 96 87 INTERFACE mpp_max 97 MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 88 MODULE PROCEDURE mppmax_a_int, mppmax_int 89 MODULE PROCEDURE mppmax_a_real_sp, mppmax_real_sp 90 MODULE PROCEDURE mppmax_a_real_dp, mppmax_real_dp 98 91 END INTERFACE 99 92 INTERFACE mpp_sum 100 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 101 & mppsum_realdd, mppsum_a_realdd 93 MODULE PROCEDURE mppsum_a_int, mppsum_int 94 MODULE PROCEDURE mppsum_realdd, mppsum_a_realdd 95 MODULE PROCEDURE mppsum_a_real_sp, mppsum_real_sp 96 MODULE PROCEDURE mppsum_a_real_dp, mppsum_real_dp 102 97 END INTERFACE 103 98 INTERFACE mpp_minloc 104 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 99 MODULE PROCEDURE mpp_minloc2d_sp ,mpp_minloc3d_sp 100 MODULE PROCEDURE mpp_minloc2d_dp ,mpp_minloc3d_dp 105 101 END INTERFACE 106 102 INTERFACE mpp_maxloc 107 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 103 MODULE PROCEDURE mpp_maxloc2d_sp ,mpp_maxloc3d_sp 104 MODULE PROCEDURE mpp_maxloc2d_dp ,mpp_maxloc3d_dp 108 105 END INTERFACE 109 106 … … 111 108 !! MPI variable definition !! 112 109 !! ========================= !! 110 #if defined key_mpp_mpi 113 111 !$AGRIF_DO_NOT_TREAT 114 112 INCLUDE 'mpif.h' 115 113 !$AGRIF_END_DO_NOT_TREAT 116 117 114 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag 115 #else 116 INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1 117 INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8 118 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 119 #endif 118 120 119 121 INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2) … … 144 146 INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north 145 147 146 ! Type of send : standard, buffered, immediate147 CHARACTER(len=1), PUBLIC :: cn_mpi_send !: type od mpi send/recieve (S=standard, B=bsend, I=isend)148 LOGICAL , PUBLIC :: l_isend = .FALSE. !: isend use indicator (T if cn_mpi_send='I')149 INTEGER , PUBLIC :: nn_buffer !: size of the buffer in case of mpi_bsend150 151 148 ! Communications summary report 152 CHARACTER(len= 400), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines153 CHARACTER(len= 400), DIMENSION(:), ALLOCATABLE :: crname_glb !: names of global comm calling routines154 CHARACTER(len= 400), DIMENSION(:), ALLOCATABLE :: crname_dlg !: names of delayed global comm calling routines149 CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines 150 CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_glb !: names of global comm calling routines 151 CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_dlg !: names of delayed global comm calling routines 155 152 INTEGER, PUBLIC :: ncom_stp = 0 !: copy of time step # istp 156 153 INTEGER, PUBLIC :: ncom_fsbc = 1 !: copy of sbc time step # nn_fsbc 157 INTEGER, PUBLIC :: ncom_dttrc = 1 !: copy of top time step # nn_dttrc158 154 INTEGER, PUBLIC :: ncom_freq !: frequency of comm diagnostic 159 155 INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE :: ncomm_sequence !: size of communicated arrays (halos) 160 INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 3000 !: max number of communication record156 INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 5000 !: max number of communication record 161 157 INTEGER, PUBLIC :: n_sequence_lbc = 0 !: # of communicated arraysvia lbc 162 158 INTEGER, PUBLIC :: n_sequence_glb = 0 !: # of global communications … … 172 168 TYPE, PUBLIC :: DELAYARR 173 169 REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL() 174 COMPLEX( wp), POINTER, DIMENSION(:) :: y1d => NULL()170 COMPLEX(dp), POINTER, DIMENSION(:) :: y1d => NULL() 175 171 END TYPE DELAYARR 176 TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC :: todelay 177 INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1 !: mpi request id of the delayed operations 178 172 TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE :: todelay !: must have SAVE for default initialization of DELAYARR 173 INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1 !: mpi request id of the delayed operations 174 175 ! timing summary report 176 REAL(dp), DIMENSION(2), PUBLIC :: waiting_time = 0._dp 177 REAL(dp) , PUBLIC :: compute_time = 0._dp, elapsed_time = 0._dp 178 179 179 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend 180 180 181 181 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 182 182 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms 183 183 184 !! * Substitutions 185 # include "do_loop_substitute.h90" 184 186 !!---------------------------------------------------------------------- 185 187 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 186 !! $Id: lib_mpp.F90 1 0538 2019-01-17 10:41:10Z clem$188 !! $Id: lib_mpp.F90 13286 2020-07-09 15:48:29Z smasson $ 187 189 !! Software governed by the CeCILL license (see ./LICENSE) 188 190 !!---------------------------------------------------------------------- 189 191 CONTAINS 190 192 191 FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 192 !!---------------------------------------------------------------------- 193 !! *** routine mynode *** 194 !! 195 !! ** Purpose : Find processor unit 196 !!---------------------------------------------------------------------- 197 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt ! 198 CHARACTER(len=*) , INTENT(in ) :: ldname ! 199 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 200 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist 201 INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output 202 INTEGER , INTENT(inout) :: kstop ! stop indicator 193 SUBROUTINE mpp_start( localComm ) 194 !!---------------------------------------------------------------------- 195 !! *** routine mpp_start *** 196 !! 197 !! ** Purpose : get mpi_comm_oce, mpprank and mppsize 198 !!---------------------------------------------------------------------- 203 199 INTEGER , OPTIONAL , INTENT(in ) :: localComm ! 204 200 ! 205 INTEGER :: mynode, ierr, code, ji, ii, ios 206 LOGICAL :: mpi_was_called 207 ! 208 NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, ln_nnogather 209 !!---------------------------------------------------------------------- 210 ! 211 ii = 1 212 WRITE(ldtxt(ii),*) ; ii = ii + 1 213 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1 214 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 215 ! 216 REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables 217 READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 218 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 219 ! 220 REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables 221 READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 222 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 223 ! 224 ! ! control print 225 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 226 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 227 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 228 ! 229 IF( jpni < 1 .OR. jpnj < 1 ) THEN 230 WRITE(ldtxt(ii),*) ' jpni and jpnj will be calculated automatically' ; ii = ii + 1 231 ELSE 232 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1 233 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 234 ENDIF 235 236 WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1 237 238 CALL mpi_initialized ( mpi_was_called, code ) 239 IF( code /= MPI_SUCCESS ) THEN 240 DO ji = 1, SIZE(ldtxt) 241 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 242 END DO 243 WRITE(*, cform_err) 244 WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 245 CALL mpi_abort( mpi_comm_world, code, ierr ) 246 ENDIF 247 248 IF( mpi_was_called ) THEN 249 ! 250 SELECT CASE ( cn_mpi_send ) 251 CASE ( 'S' ) ! Standard mpi send (blocking) 252 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 253 CASE ( 'B' ) ! Buffer mpi send (blocking) 254 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 255 IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr ) 256 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 257 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 258 l_isend = .TRUE. 259 CASE DEFAULT 260 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 261 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 262 kstop = kstop + 1 263 END SELECT 264 ! 265 ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 266 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 267 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 268 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 269 kstop = kstop + 1 270 ELSE 271 SELECT CASE ( cn_mpi_send ) 272 CASE ( 'S' ) ! Standard mpi send (blocking) 273 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 274 CALL mpi_init( ierr ) 275 CASE ( 'B' ) ! Buffer mpi send (blocking) 276 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 277 IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr ) 278 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 279 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 280 l_isend = .TRUE. 281 CALL mpi_init( ierr ) 282 CASE DEFAULT 283 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 284 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 285 kstop = kstop + 1 286 END SELECT 287 ! 288 ENDIF 289 201 INTEGER :: ierr 202 LOGICAL :: llmpi_init 203 !!---------------------------------------------------------------------- 204 #if defined key_mpp_mpi 205 ! 206 CALL mpi_initialized ( llmpi_init, ierr ) 207 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) 208 209 IF( .NOT. llmpi_init ) THEN 210 IF( PRESENT(localComm) ) THEN 211 WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' 212 WRITE(ctmp2,*) ' without calling MPI_Init before ! ' 213 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 214 ENDIF 215 CALL mpi_init( ierr ) 216 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) 217 ENDIF 218 290 219 IF( PRESENT(localComm) ) THEN 291 220 IF( Agrif_Root() ) THEN … … 293 222 ENDIF 294 223 ELSE 295 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code) 296 IF( code /= MPI_SUCCESS ) THEN 297 DO ji = 1, SIZE(ldtxt) 298 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 299 END DO 300 WRITE(*, cform_err) 301 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 302 CALL mpi_abort( mpi_comm_world, code, ierr ) 303 ENDIF 304 ENDIF 305 306 #if defined key_agrif 224 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) 225 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) 226 ENDIF 227 228 # if defined key_agrif 307 229 IF( Agrif_Root() ) THEN 308 230 CALL Agrif_MPI_Init(mpi_comm_oce) … … 310 232 CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) 311 233 ENDIF 312 # endif234 # endif 313 235 314 236 CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 315 237 CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) 316 mynode = mpprank317 318 IF( mynode == 0 ) THEN319 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )320 WRITE(kumond, nammpp)321 ENDIF322 238 ! 323 239 CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 324 240 ! 325 END FUNCTION mynode 326 327 !!---------------------------------------------------------------------- 328 !! *** routine mpp_lnk_(2,3,4)d *** 329 !! 330 !! * Argument : dummy argument use in mpp_lnk_... routines 331 !! ptab : array or pointer of arrays on which the boundary condition is applied 332 !! cd_nat : nature of array grid-points 333 !! psgn : sign used across the north fold boundary 334 !! kfld : optional, number of pt3d arrays 335 !! cd_mpp : optional, fill the overlap area only 336 !! pval : optional, background value (used at closed boundaries) 337 !!---------------------------------------------------------------------- 338 ! 339 ! !== 2D array and array of 2D pointer ==! 340 ! 341 # define DIM_2d 342 # define ROUTINE_LNK mpp_lnk_2d 343 # include "mpp_lnk_generic.h90" 344 # undef ROUTINE_LNK 345 # define MULTI 346 # define ROUTINE_LNK mpp_lnk_2d_ptr 347 # include "mpp_lnk_generic.h90" 348 # undef ROUTINE_LNK 349 # undef MULTI 350 # undef DIM_2d 351 ! 352 ! !== 3D array and array of 3D pointer ==! 353 ! 354 # define DIM_3d 355 # define ROUTINE_LNK mpp_lnk_3d 356 # include "mpp_lnk_generic.h90" 357 # undef ROUTINE_LNK 358 # define MULTI 359 # define ROUTINE_LNK mpp_lnk_3d_ptr 360 # include "mpp_lnk_generic.h90" 361 # undef ROUTINE_LNK 362 # undef MULTI 363 # undef DIM_3d 364 ! 365 ! !== 4D array and array of 4D pointer ==! 366 ! 367 # define DIM_4d 368 # define ROUTINE_LNK mpp_lnk_4d 369 # include "mpp_lnk_generic.h90" 370 # undef ROUTINE_LNK 371 # define MULTI 372 # define ROUTINE_LNK mpp_lnk_4d_ptr 373 # include "mpp_lnk_generic.h90" 374 # undef ROUTINE_LNK 375 # undef MULTI 376 # undef DIM_4d 377 378 !!---------------------------------------------------------------------- 379 !! *** routine mpp_nfd_(2,3,4)d *** 380 !! 381 !! * Argument : dummy argument use in mpp_nfd_... routines 382 !! ptab : array or pointer of arrays on which the boundary condition is applied 383 !! cd_nat : nature of array grid-points 384 !! psgn : sign used across the north fold boundary 385 !! kfld : optional, number of pt3d arrays 386 !! cd_mpp : optional, fill the overlap area only 387 !! pval : optional, background value (used at closed boundaries) 388 !!---------------------------------------------------------------------- 389 ! 390 ! !== 2D array and array of 2D pointer ==! 391 ! 392 # define DIM_2d 393 # define ROUTINE_NFD mpp_nfd_2d 394 # include "mpp_nfd_generic.h90" 395 # undef ROUTINE_NFD 396 # define MULTI 397 # define ROUTINE_NFD mpp_nfd_2d_ptr 398 # include "mpp_nfd_generic.h90" 399 # undef ROUTINE_NFD 400 # undef MULTI 401 # undef DIM_2d 402 ! 403 ! !== 3D array and array of 3D pointer ==! 404 ! 405 # define DIM_3d 406 # define ROUTINE_NFD mpp_nfd_3d 407 # include "mpp_nfd_generic.h90" 408 # undef ROUTINE_NFD 409 # define MULTI 410 # define ROUTINE_NFD mpp_nfd_3d_ptr 411 # include "mpp_nfd_generic.h90" 412 # undef ROUTINE_NFD 413 # undef MULTI 414 # undef DIM_3d 415 ! 416 ! !== 4D array and array of 4D pointer ==! 417 ! 418 # define DIM_4d 419 # define ROUTINE_NFD mpp_nfd_4d 420 # include "mpp_nfd_generic.h90" 421 # undef ROUTINE_NFD 422 # define MULTI 423 # define ROUTINE_NFD mpp_nfd_4d_ptr 424 # include "mpp_nfd_generic.h90" 425 # undef ROUTINE_NFD 426 # undef MULTI 427 # undef DIM_4d 428 429 430 !!---------------------------------------------------------------------- 431 !! 432 !! load_array & mpp_lnk_2d_9 à generaliser a 3D et 4D 433 434 435 !! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!! 436 437 438 !!---------------------------------------------------------------------- 439 241 #else 242 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 243 mppsize = 1 244 mpprank = 0 245 #endif 246 END SUBROUTINE mpp_start 440 247 441 248 … … 454 261 !! 455 262 INTEGER :: iflag 456 !!----------------------------------------------------------------------457 ! 458 SELECT CASE ( cn_mpi_send )459 CASE ( 'S' ) ! Standard mpi send (blocking) 460 CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag )461 CASE ( 'B' ) ! Buffer mpi send (blocking)462 CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag )463 CASE ( 'I' ) ! Immediate mpi send (non-blocking send)464 ! be carefull, one more argument here : the mpi request identifier..465 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag )466 END SELECT 263 INTEGER :: mpi_working_type 264 !!---------------------------------------------------------------------- 265 ! 266 #if defined key_mpp_mpi 267 IF (wp == dp) THEN 268 mpi_working_type = mpi_double_precision 269 ELSE 270 mpi_working_type = mpi_real 271 END IF 272 CALL mpi_isend( pmess, kbytes, mpi_working_type, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 273 #endif 467 274 ! 468 275 END SUBROUTINE mppsend 276 277 278 SUBROUTINE mppsend_dp( ktyp, pmess, kbytes, kdest, md_req ) 279 !!---------------------------------------------------------------------- 280 !! *** routine mppsend *** 281 !! 282 !! ** Purpose : Send messag passing array 283 !! 284 !!---------------------------------------------------------------------- 285 REAL(dp), INTENT(inout) :: pmess(*) ! array of real 286 INTEGER , INTENT(in ) :: kbytes ! size of the array pmess 287 INTEGER , INTENT(in ) :: kdest ! receive process number 288 INTEGER , INTENT(in ) :: ktyp ! tag of the message 289 INTEGER , INTENT(in ) :: md_req ! argument for isend 290 !! 291 INTEGER :: iflag 292 !!---------------------------------------------------------------------- 293 ! 294 #if defined key_mpp_mpi 295 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 296 #endif 297 ! 298 END SUBROUTINE mppsend_dp 299 300 301 SUBROUTINE mppsend_sp( ktyp, pmess, kbytes, kdest, md_req ) 302 !!---------------------------------------------------------------------- 303 !! *** routine mppsend *** 304 !! 305 !! ** Purpose : Send messag passing array 306 !! 307 !!---------------------------------------------------------------------- 308 REAL(sp), INTENT(inout) :: pmess(*) ! array of real 309 INTEGER , INTENT(in ) :: kbytes ! size of the array pmess 310 INTEGER , INTENT(in ) :: kdest ! receive process number 311 INTEGER , INTENT(in ) :: ktyp ! tag of the message 312 INTEGER , INTENT(in ) :: md_req ! argument for isend 313 !! 314 INTEGER :: iflag 315 !!---------------------------------------------------------------------- 316 ! 317 #if defined key_mpp_mpi 318 CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 319 #endif 320 ! 321 END SUBROUTINE mppsend_sp 469 322 470 323 … … 484 337 INTEGER :: iflag 485 338 INTEGER :: use_source 486 !!---------------------------------------------------------------------- 487 ! 339 INTEGER :: mpi_working_type 340 !!---------------------------------------------------------------------- 341 ! 342 #if defined key_mpp_mpi 488 343 ! If a specific process number has been passed to the receive call, 489 344 ! use that one. Default is to use mpi_any_source … … 491 346 IF( PRESENT(ksource) ) use_source = ksource 492 347 ! 348 IF (wp == dp) THEN 349 mpi_working_type = mpi_double_precision 350 ELSE 351 mpi_working_type = mpi_real 352 END IF 353 CALL mpi_recv( pmess, kbytes, mpi_working_type, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 354 #endif 355 ! 356 END SUBROUTINE mpprecv 357 358 SUBROUTINE mpprecv_dp( ktyp, pmess, kbytes, ksource ) 359 !!---------------------------------------------------------------------- 360 !! *** routine mpprecv *** 361 !! 362 !! ** Purpose : Receive messag passing array 363 !! 364 !!---------------------------------------------------------------------- 365 REAL(dp), INTENT(inout) :: pmess(*) ! array of real 366 INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess 367 INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message 368 INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number 369 !! 370 INTEGER :: istatus(mpi_status_size) 371 INTEGER :: iflag 372 INTEGER :: use_source 373 !!---------------------------------------------------------------------- 374 ! 375 #if defined key_mpp_mpi 376 ! If a specific process number has been passed to the receive call, 377 ! use that one. Default is to use mpi_any_source 378 use_source = mpi_any_source 379 IF( PRESENT(ksource) ) use_source = ksource 380 ! 493 381 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 494 ! 495 END SUBROUTINE mpprecv 382 #endif 383 ! 384 END SUBROUTINE mpprecv_dp 385 386 387 SUBROUTINE mpprecv_sp( ktyp, pmess, kbytes, ksource ) 388 !!---------------------------------------------------------------------- 389 !! *** routine mpprecv *** 390 !! 391 !! ** Purpose : Receive messag passing array 392 !! 393 !!---------------------------------------------------------------------- 394 REAL(sp), INTENT(inout) :: pmess(*) ! array of real 395 INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess 396 INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message 397 INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number 398 !! 399 INTEGER :: istatus(mpi_status_size) 400 INTEGER :: iflag 401 INTEGER :: use_source 402 !!---------------------------------------------------------------------- 403 ! 404 #if defined key_mpp_mpi 405 ! If a specific process number has been passed to the receive call, 406 ! use that one. Default is to use mpi_any_source 407 use_source = mpi_any_source 408 IF( PRESENT(ksource) ) use_source = ksource 409 ! 410 CALL mpi_recv( pmess, kbytes, mpi_real, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 411 #endif 412 ! 413 END SUBROUTINE mpprecv_sp 496 414 497 415 … … 512 430 ! 513 431 itaille = jpi * jpj 432 #if defined key_mpp_mpi 514 433 CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , & 515 434 & mpi_double_precision, kp , mpi_comm_oce, ierror ) 435 #else 436 pio(:,:,1) = ptab(:,:) 437 #endif 516 438 ! 517 439 END SUBROUTINE mppgather … … 535 457 itaille = jpi * jpj 536 458 ! 459 #if defined key_mpp_mpi 537 460 CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & 538 461 & mpi_double_precision, kp , mpi_comm_oce, ierror ) 462 #else 463 ptab(:,:) = pio(:,:,1) 464 #endif 539 465 ! 540 466 END SUBROUTINE mppscatter … … 550 476 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 551 477 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 552 COMPLEX( wp), INTENT(in ), DIMENSION(:) :: y_in478 COMPLEX(dp), INTENT(in ), DIMENSION(:) :: y_in 553 479 REAL(wp), INTENT( out), DIMENSION(:) :: pout 554 480 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine … … 558 484 INTEGER :: idvar 559 485 INTEGER :: ierr, ilocalcomm 560 COMPLEX(wp), ALLOCATABLE, DIMENSION(:) :: ytmp 561 !!---------------------------------------------------------------------- 486 COMPLEX(dp), ALLOCATABLE, DIMENSION(:) :: ytmp 487 !!---------------------------------------------------------------------- 488 #if defined key_mpp_mpi 562 489 ilocalcomm = mpi_comm_oce 563 490 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 598 525 599 526 ! send y_in into todelay(idvar)%y1d with a non-blocking communication 600 #if defined key_mpi2 601 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 527 # if defined key_mpi2 528 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 529 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) 530 ndelayid(idvar) = 1 531 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 532 # else 533 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 534 # endif 602 535 #else 603 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr)536 pout(:) = REAL(y_in(:), wp) 604 537 #endif 605 538 … … 624 557 INTEGER :: idvar 625 558 INTEGER :: ierr, ilocalcomm 626 !!---------------------------------------------------------------------- 559 INTEGER :: MPI_TYPE 560 !!---------------------------------------------------------------------- 561 562 #if defined key_mpp_mpi 563 if( wp == dp ) then 564 MPI_TYPE = MPI_DOUBLE_PRECISION 565 else if ( wp == sp ) then 566 MPI_TYPE = MPI_REAL 567 else 568 CALL ctl_stop( "Error defining type, wp is neither dp nor sp" ) 569 570 end if 571 627 572 ilocalcomm = mpi_comm_oce 628 573 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 659 604 660 605 ! send p_in into todelay(idvar)%z1d with a non-blocking communication 661 #if defined key_mpi2 662 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 606 # if defined key_mpi2 607 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 608 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 609 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 610 # else 611 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 612 # endif 663 613 #else 664 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr)614 pout(:) = p_in(:) 665 615 #endif 666 616 … … 678 628 INTEGER :: ierr 679 629 !!---------------------------------------------------------------------- 630 #if defined key_mpp_mpi 680 631 IF( ndelayid(kid) /= -2 ) THEN 681 632 #if ! defined key_mpi2 633 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 682 634 CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! make sure todelay(kid) is received 635 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 683 636 #endif 684 637 IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d 685 638 ndelayid(kid) = -2 ! add flag to know that mpi_wait was already called on kid 686 639 ENDIF 640 #endif 687 641 END SUBROUTINE mpp_delay_rcv 642 643 SUBROUTINE mpp_bcast_nml( cdnambuff , kleng ) 644 CHARACTER(LEN=:) , ALLOCATABLE, INTENT(INOUT) :: cdnambuff 645 INTEGER , INTENT(INOUT) :: kleng 646 !!---------------------------------------------------------------------- 647 !! *** routine mpp_bcast_nml *** 648 !! 649 !! ** Purpose : broadcast namelist character buffer 650 !! 651 !!---------------------------------------------------------------------- 652 !! 653 INTEGER :: iflag 654 !!---------------------------------------------------------------------- 655 ! 656 #if defined key_mpp_mpi 657 call MPI_BCAST(kleng, 1, MPI_INT, 0, mpi_comm_oce, iflag) 658 call MPI_BARRIER(mpi_comm_oce, iflag) 659 !$AGRIF_DO_NOT_TREAT 660 IF ( .NOT. ALLOCATED(cdnambuff) ) ALLOCATE( CHARACTER(LEN=kleng) :: cdnambuff ) 661 !$AGRIF_END_DO_NOT_TREAT 662 call MPI_BCAST(cdnambuff, kleng, MPI_CHARACTER, 0, mpi_comm_oce, iflag) 663 call MPI_BARRIER(mpi_comm_oce, iflag) 664 #endif 665 ! 666 END SUBROUTINE mpp_bcast_nml 688 667 689 668 … … 707 686 # undef INTEGER_TYPE 708 687 ! 688 !! 689 !! ---- SINGLE PRECISION VERSIONS 690 !! 691 # define SINGLE_PRECISION 709 692 # define REAL_TYPE 710 693 # define DIM_0d 711 # define ROUTINE_ALLREDUCE mppmax_real 694 # define ROUTINE_ALLREDUCE mppmax_real_sp 712 695 # include "mpp_allreduce_generic.h90" 713 696 # undef ROUTINE_ALLREDUCE 714 697 # undef DIM_0d 715 698 # define DIM_1d 716 # define ROUTINE_ALLREDUCE mppmax_a_real 699 # define ROUTINE_ALLREDUCE mppmax_a_real_sp 700 # include "mpp_allreduce_generic.h90" 701 # undef ROUTINE_ALLREDUCE 702 # undef DIM_1d 703 # undef SINGLE_PRECISION 704 !! 705 !! 706 !! ---- DOUBLE PRECISION VERSIONS 707 !! 708 ! 709 # define DIM_0d 710 # define ROUTINE_ALLREDUCE mppmax_real_dp 711 # include "mpp_allreduce_generic.h90" 712 # undef ROUTINE_ALLREDUCE 713 # undef DIM_0d 714 # define DIM_1d 715 # define ROUTINE_ALLREDUCE mppmax_a_real_dp 717 716 # include "mpp_allreduce_generic.h90" 718 717 # undef ROUTINE_ALLREDUCE … … 739 738 # undef INTEGER_TYPE 740 739 ! 740 !! 741 !! ---- SINGLE PRECISION VERSIONS 742 !! 743 # define SINGLE_PRECISION 741 744 # define REAL_TYPE 742 745 # define DIM_0d 743 # define ROUTINE_ALLREDUCE mppmin_real 746 # define ROUTINE_ALLREDUCE mppmin_real_sp 744 747 # include "mpp_allreduce_generic.h90" 745 748 # undef ROUTINE_ALLREDUCE 746 749 # undef DIM_0d 747 750 # define DIM_1d 748 # define ROUTINE_ALLREDUCE mppmin_a_real 751 # define ROUTINE_ALLREDUCE mppmin_a_real_sp 752 # include "mpp_allreduce_generic.h90" 753 # undef ROUTINE_ALLREDUCE 754 # undef DIM_1d 755 # undef SINGLE_PRECISION 756 !! 757 !! ---- DOUBLE PRECISION VERSIONS 758 !! 759 760 # define DIM_0d 761 # define ROUTINE_ALLREDUCE mppmin_real_dp 762 # include "mpp_allreduce_generic.h90" 763 # undef ROUTINE_ALLREDUCE 764 # undef DIM_0d 765 # define DIM_1d 766 # define ROUTINE_ALLREDUCE mppmin_a_real_dp 749 767 # include "mpp_allreduce_generic.h90" 750 768 # undef ROUTINE_ALLREDUCE … … 772 790 # undef DIM_1d 773 791 # undef INTEGER_TYPE 774 ! 792 793 !! 794 !! ---- SINGLE PRECISION VERSIONS 795 !! 796 # define OPERATION_SUM 797 # define SINGLE_PRECISION 775 798 # define REAL_TYPE 776 799 # define DIM_0d 777 # define ROUTINE_ALLREDUCE mppsum_real 800 # define ROUTINE_ALLREDUCE mppsum_real_sp 778 801 # include "mpp_allreduce_generic.h90" 779 802 # undef ROUTINE_ALLREDUCE 780 803 # undef DIM_0d 781 804 # define DIM_1d 782 # define ROUTINE_ALLREDUCE mppsum_a_real 805 # define ROUTINE_ALLREDUCE mppsum_a_real_sp 806 # include "mpp_allreduce_generic.h90" 807 # undef ROUTINE_ALLREDUCE 808 # undef DIM_1d 809 # undef REAL_TYPE 810 # undef OPERATION_SUM 811 812 # undef SINGLE_PRECISION 813 814 !! 815 !! ---- DOUBLE PRECISION VERSIONS 816 !! 817 # define OPERATION_SUM 818 # define REAL_TYPE 819 # define DIM_0d 820 # define ROUTINE_ALLREDUCE mppsum_real_dp 821 # include "mpp_allreduce_generic.h90" 822 # undef ROUTINE_ALLREDUCE 823 # undef DIM_0d 824 # define DIM_1d 825 # define ROUTINE_ALLREDUCE mppsum_a_real_dp 783 826 # include "mpp_allreduce_generic.h90" 784 827 # undef ROUTINE_ALLREDUCE … … 807 850 !!---------------------------------------------------------------------- 808 851 !! 852 !! 853 !! ---- SINGLE PRECISION VERSIONS 854 !! 855 # define SINGLE_PRECISION 809 856 # define OPERATION_MINLOC 810 857 # define DIM_2d 811 # define ROUTINE_LOC mpp_minloc2d 858 # define ROUTINE_LOC mpp_minloc2d_sp 812 859 # include "mpp_loc_generic.h90" 813 860 # undef ROUTINE_LOC 814 861 # undef DIM_2d 815 862 # define DIM_3d 816 # define ROUTINE_LOC mpp_minloc3d 863 # define ROUTINE_LOC mpp_minloc3d_sp 817 864 # include "mpp_loc_generic.h90" 818 865 # undef ROUTINE_LOC … … 822 869 # define OPERATION_MAXLOC 823 870 # define DIM_2d 824 # define ROUTINE_LOC mpp_maxloc2d 871 # define ROUTINE_LOC mpp_maxloc2d_sp 825 872 # include "mpp_loc_generic.h90" 826 873 # undef ROUTINE_LOC 827 874 # undef DIM_2d 828 875 # define DIM_3d 829 # define ROUTINE_LOC mpp_maxloc3d 876 # define ROUTINE_LOC mpp_maxloc3d_sp 830 877 # include "mpp_loc_generic.h90" 831 878 # undef ROUTINE_LOC 832 879 # undef DIM_3d 833 880 # undef OPERATION_MAXLOC 881 # undef SINGLE_PRECISION 882 !! 883 !! ---- DOUBLE PRECISION VERSIONS 884 !! 885 # define OPERATION_MINLOC 886 # define DIM_2d 887 # define ROUTINE_LOC mpp_minloc2d_dp 888 # include "mpp_loc_generic.h90" 889 # undef ROUTINE_LOC 890 # undef DIM_2d 891 # define DIM_3d 892 # define ROUTINE_LOC mpp_minloc3d_dp 893 # include "mpp_loc_generic.h90" 894 # undef ROUTINE_LOC 895 # undef DIM_3d 896 # undef OPERATION_MINLOC 897 898 # define OPERATION_MAXLOC 899 # define DIM_2d 900 # define ROUTINE_LOC mpp_maxloc2d_dp 901 # include "mpp_loc_generic.h90" 902 # undef ROUTINE_LOC 903 # undef DIM_2d 904 # define DIM_3d 905 # define ROUTINE_LOC mpp_maxloc3d_dp 906 # include "mpp_loc_generic.h90" 907 # undef ROUTINE_LOC 908 # undef DIM_3d 909 # undef OPERATION_MAXLOC 910 834 911 835 912 SUBROUTINE mppsync() … … 843 920 !!----------------------------------------------------------------------- 844 921 ! 922 #if defined key_mpp_mpi 845 923 CALL mpi_barrier( mpi_comm_oce, ierror ) 924 #endif 846 925 ! 847 926 END SUBROUTINE mppsync 848 927 849 928 850 SUBROUTINE mppstop( ld final, ld_force_abort )929 SUBROUTINE mppstop( ld_abort ) 851 930 !!---------------------------------------------------------------------- 852 931 !! *** routine mppstop *** … … 855 934 !! 856 935 !!---------------------------------------------------------------------- 857 LOGICAL, OPTIONAL, INTENT(in) :: ldfinal ! source process number 858 LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort ! source process number 859 LOGICAL :: llfinal, ll_force_abort 936 LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number 937 LOGICAL :: ll_abort 860 938 INTEGER :: info 861 939 !!---------------------------------------------------------------------- 862 llfinal = .FALSE. 863 IF( PRESENT(ldfinal) ) llfinal = ldfinal 864 ll_force_abort = .FALSE. 865 IF( PRESENT(ld_force_abort) ) ll_force_abort = ld_force_abort 866 ! 867 IF(ll_force_abort) THEN 940 ll_abort = .FALSE. 941 IF( PRESENT(ld_abort) ) ll_abort = ld_abort 942 ! 943 #if defined key_mpp_mpi 944 IF(ll_abort) THEN 868 945 CALL mpi_abort( MPI_COMM_WORLD ) 869 946 ELSE … … 871 948 CALL mpi_finalize( info ) 872 949 ENDIF 873 IF( .NOT. llfinal ) STOP 123456 950 #endif 951 IF( ll_abort ) STOP 123 874 952 ! 875 953 END SUBROUTINE mppstop … … 883 961 !!---------------------------------------------------------------------- 884 962 ! 963 #if defined key_mpp_mpi 885 964 CALL MPI_COMM_FREE(kcom, ierr) 965 #endif 886 966 ! 887 967 END SUBROUTINE mpp_comm_free … … 913 993 INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork 914 994 !!---------------------------------------------------------------------- 995 #if defined key_mpp_mpi 915 996 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world 916 997 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world … … 918 999 ! 919 1000 ALLOCATE( kwork(jpnij), STAT=ierr ) 920 IF( ierr /= 0 ) THEN 921 WRITE(kumout, cform_err) 922 WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' 923 CALL mppstop 924 ENDIF 1001 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') 925 1002 926 1003 IF( jpnj == 1 ) THEN … … 984 1061 985 1062 DEALLOCATE(kwork) 1063 #endif 986 1064 987 1065 END SUBROUTINE mpp_ini_znl … … 1015 1093 !!---------------------------------------------------------------------- 1016 1094 ! 1095 #if defined key_mpp_mpi 1017 1096 njmppmax = MAXVAL( njmppt ) 1018 1097 ! 1019 1098 ! Look for how many procs on the northern boundary 1020 1099 ndim_rank_north = 0 1021 DO jjproc = 1, jpni j1022 IF( n jmppt(jjproc) == njmppmax) ndim_rank_north = ndim_rank_north + 11100 DO jjproc = 1, jpni 1101 IF( nfproc(jjproc) /= -1 ) ndim_rank_north = ndim_rank_north + 1 1023 1102 END DO 1024 1103 ! … … 1030 1109 ! Note : the rank start at 0 in MPI 1031 1110 ii = 0 1032 DO ji = 1, jpni j1033 IF ( n jmppt(ji) == njmppmax) THEN1111 DO ji = 1, jpni 1112 IF ( nfproc(ji) /= -1 ) THEN 1034 1113 ii=ii+1 1035 nrank_north(ii)= ji-11114 nrank_north(ii)=nfproc(ji) 1036 1115 END IF 1037 1116 END DO … … 1046 1125 CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) 1047 1126 ! 1127 #endif 1048 1128 END SUBROUTINE mpp_ini_north 1049 1050 1051 SUBROUTINE mpi_init_oce( ldtxt, ksft, code )1052 !!---------------------------------------------------------------------1053 !! *** routine mpp_init.opa ***1054 !!1055 !! ** Purpose :: export and attach a MPI buffer for bsend1056 !!1057 !! ** Method :: define buffer size in namelist, if 0 no buffer attachment1058 !! but classical mpi_init1059 !!1060 !! History :: 01/11 :: IDRIS initial version for IBM only1061 !! 08/04 :: R. Benshila, generalisation1062 !!---------------------------------------------------------------------1063 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt1064 INTEGER , INTENT(inout) :: ksft1065 INTEGER , INTENT( out) :: code1066 INTEGER :: ierr, ji1067 LOGICAL :: mpi_was_called1068 !!---------------------------------------------------------------------1069 !1070 CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization1071 IF ( code /= MPI_SUCCESS ) THEN1072 DO ji = 1, SIZE(ldtxt)1073 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1074 END DO1075 WRITE(*, cform_err)1076 WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'1077 CALL mpi_abort( mpi_comm_world, code, ierr )1078 ENDIF1079 !1080 IF( .NOT. mpi_was_called ) THEN1081 CALL mpi_init( code )1082 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code )1083 IF ( code /= MPI_SUCCESS ) THEN1084 DO ji = 1, SIZE(ldtxt)1085 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1086 END DO1087 WRITE(*, cform_err)1088 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'1089 CALL mpi_abort( mpi_comm_world, code, ierr )1090 ENDIF1091 ENDIF1092 !1093 IF( nn_buffer > 0 ) THEN1094 WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 11095 ! Buffer allocation and attachment1096 ALLOCATE( tampon(nn_buffer), stat = ierr )1097 IF( ierr /= 0 ) THEN1098 DO ji = 1, SIZE(ldtxt)1099 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1100 END DO1101 WRITE(*, cform_err)1102 WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr1103 CALL mpi_abort( mpi_comm_world, code, ierr )1104 END IF1105 CALL mpi_buffer_attach( tampon, nn_buffer, code )1106 ENDIF1107 !1108 END SUBROUTINE mpi_init_oce1109 1129 1110 1130 … … 1117 1137 !!--------------------------------------------------------------------- 1118 1138 INTEGER , INTENT(in) :: ilen, itype 1119 COMPLEX( wp), DIMENSION(ilen), INTENT(in) :: ydda1120 COMPLEX( wp), DIMENSION(ilen), INTENT(inout) :: yddb1121 ! 1122 REAL( wp) :: zerr, zt1, zt2 ! local work variables1139 COMPLEX(dp), DIMENSION(ilen), INTENT(in) :: ydda 1140 COMPLEX(dp), DIMENSION(ilen), INTENT(inout) :: yddb 1141 ! 1142 REAL(dp) :: zerr, zt1, zt2 ! local work variables 1123 1143 INTEGER :: ji, ztmp ! local scalar 1124 1144 !!--------------------------------------------------------------------- … … 1140 1160 1141 1161 1142 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj)1143 !!---------------------------------------------------------------------1144 !! *** routine mpp_lbc_north_icb ***1145 !!1146 !! ** Purpose : Ensure proper north fold horizontal bondary condition1147 !! in mpp configuration in case of jpn1 > 1 and for 2d1148 !! array with outer extra halo1149 !!1150 !! ** Method : North fold condition and mpp with more than one proc1151 !! in i-direction require a specific treatment. We gather1152 !! the 4+kextj northern lines of the global domain on 11153 !! processor and apply lbc north-fold on this sub array.1154 !! Then we scatter the north fold array back to the processors.1155 !! This routine accounts for an extra halo with icebergs1156 !! and assumes ghost rows and columns have been suppressed.1157 !!1158 !!----------------------------------------------------------------------1159 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo1160 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points1161 ! ! = T , U , V , F or W -points1162 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the1163 !! ! north fold, = 1. otherwise1164 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold1165 !1166 INTEGER :: ji, jj, jr1167 INTEGER :: ierr, itaille, ildi, ilei, iilb1168 INTEGER :: ipj, ij, iproc1169 !1170 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e1171 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e1172 !!----------------------------------------------------------------------1173 !1174 ipj=41175 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , &1176 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , &1177 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) )1178 !1179 ztab_e(:,:) = 0._wp1180 znorthloc_e(:,:) = 0._wp1181 !1182 ij = 1 - kextj1183 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e1184 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1185 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)1186 ij = ij + 11187 END DO1188 !1189 itaille = jpimax * ( ipj + 2*kextj )1190 !1191 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, &1192 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, &1193 & ncomm_north, ierr )1194 !1195 !1196 DO jr = 1, ndim_rank_north ! recover the global north array1197 iproc = nrank_north(jr) + 11198 ildi = nldit (iproc)1199 ilei = nleit (iproc)1200 iilb = nimppt(iproc)1201 DO jj = 1-kextj, ipj+kextj1202 DO ji = ildi, ilei1203 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)1204 END DO1205 END DO1206 END DO1207 1208 ! 2. North-Fold boundary conditions1209 ! ----------------------------------1210 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )1211 1212 ij = 1 - kextj1213 !! Scatter back to pt2d1214 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1215 DO ji= 1, jpi1216 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)1217 END DO1218 ij = ij +11219 END DO1220 !1221 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )1222 !1223 END SUBROUTINE mpp_lbc_north_icb1224 1225 1226 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj )1227 !!----------------------------------------------------------------------1228 !! *** routine mpp_lnk_2d_icb ***1229 !!1230 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs)1231 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)1232 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.1233 !!1234 !! ** Method : Use mppsend and mpprecv function for passing mask1235 !! between processors following neighboring subdomains.1236 !! domain parameters1237 !! jpi : first dimension of the local subdomain1238 !! jpj : second dimension of the local subdomain1239 !! kexti : number of columns for extra outer halo1240 !! kextj : number of rows for extra outer halo1241 !! nbondi : mark for "east-west local boundary"1242 !! nbondj : mark for "north-south local boundary"1243 !! noea : number for local neighboring processors1244 !! nowe : number for local neighboring processors1245 !! noso : number for local neighboring processors1246 !! nono : number for local neighboring processors1247 !!----------------------------------------------------------------------1248 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine1249 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo1250 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points1251 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold1252 INTEGER , INTENT(in ) :: kexti ! extra i-halo width1253 INTEGER , INTENT(in ) :: kextj ! extra j-halo width1254 !1255 INTEGER :: jl ! dummy loop indices1256 INTEGER :: imigr, iihom, ijhom ! local integers1257 INTEGER :: ipreci, iprecj ! - -1258 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1259 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1260 !!1261 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn1262 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew1263 !!----------------------------------------------------------------------1264 1265 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area1266 iprecj = nn_hls + kextj1267 1268 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )1269 1270 ! 1. standard boundary treatment1271 ! ------------------------------1272 ! Order matters Here !!!!1273 !1274 ! ! East-West boundaries1275 ! !* Cyclic east-west1276 IF( l_Iperio ) THEN1277 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east1278 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west1279 !1280 ELSE !* closed1281 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point1282 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west1283 ENDIF1284 ! ! North-South boundaries1285 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split)1286 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north1287 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south1288 ELSE !* closed1289 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point1290 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south1291 ENDIF1292 !1293 1294 ! north fold treatment1295 ! -----------------------1296 IF( npolj /= 0 ) THEN1297 !1298 SELECT CASE ( jpni )1299 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1300 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1301 END SELECT1302 !1303 ENDIF1304 1305 ! 2. East and west directions exchange1306 ! ------------------------------------1307 ! we play with the neigbours AND the row number because of the periodicity1308 !1309 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions1310 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1311 iihom = jpi-nreci-kexti1312 DO jl = 1, ipreci1313 r2dew(:,jl,1) = pt2d(nn_hls+jl,:)1314 r2dwe(:,jl,1) = pt2d(iihom +jl,:)1315 END DO1316 END SELECT1317 !1318 ! ! Migrations1319 imigr = ipreci * ( jpj + 2*kextj )1320 !1321 SELECT CASE ( nbondi )1322 CASE ( -1 )1323 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )1324 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1325 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1326 CASE ( 0 )1327 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1328 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )1329 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1330 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1331 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1332 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1333 CASE ( 1 )1334 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1335 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1336 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1337 END SELECT1338 !1339 ! ! Write Dirichlet lateral conditions1340 iihom = jpi - nn_hls1341 !1342 SELECT CASE ( nbondi )1343 CASE ( -1 )1344 DO jl = 1, ipreci1345 pt2d(iihom+jl,:) = r2dew(:,jl,2)1346 END DO1347 CASE ( 0 )1348 DO jl = 1, ipreci1349 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1350 pt2d(iihom+jl,:) = r2dew(:,jl,2)1351 END DO1352 CASE ( 1 )1353 DO jl = 1, ipreci1354 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1355 END DO1356 END SELECT1357 1358 1359 ! 3. North and south directions1360 ! -----------------------------1361 ! always closed : we play only with the neigbours1362 !1363 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions1364 ijhom = jpj-nrecj-kextj1365 DO jl = 1, iprecj1366 r2dsn(:,jl,1) = pt2d(:,ijhom +jl)1367 r2dns(:,jl,1) = pt2d(:,nn_hls+jl)1368 END DO1369 ENDIF1370 !1371 ! ! Migrations1372 imigr = iprecj * ( jpi + 2*kexti )1373 !1374 SELECT CASE ( nbondj )1375 CASE ( -1 )1376 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )1377 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1378 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1379 CASE ( 0 )1380 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1381 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )1382 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1383 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1384 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1385 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1386 CASE ( 1 )1387 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1388 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1389 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1390 END SELECT1391 !1392 ! ! Write Dirichlet lateral conditions1393 ijhom = jpj - nn_hls1394 !1395 SELECT CASE ( nbondj )1396 CASE ( -1 )1397 DO jl = 1, iprecj1398 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1399 END DO1400 CASE ( 0 )1401 DO jl = 1, iprecj1402 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1403 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1404 END DO1405 CASE ( 1 )1406 DO jl = 1, iprecj1407 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1408 END DO1409 END SELECT1410 !1411 END SUBROUTINE mpp_lnk_2d_icb1412 1413 1414 1162 SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) 1415 1163 !!---------------------------------------------------------------------- … … 1423 1171 LOGICAL , OPTIONAL, INTENT(in ) :: ld_lbc, ld_glb, ld_dlg 1424 1172 !! 1173 CHARACTER(len=128) :: ccountname ! name of a subroutine to count communications 1425 1174 LOGICAL :: ll_lbc, ll_glb, ll_dlg 1426 INTEGER :: ji, jj, jk, jh, jf ! dummy loop indices 1427 !!---------------------------------------------------------------------- 1175 INTEGER :: ji, jj, jk, jh, jf, jcount ! dummy loop indices 1176 !!---------------------------------------------------------------------- 1177 #if defined key_mpp_mpi 1428 1178 ! 1429 1179 ll_lbc = .FALSE. … … 1435 1185 ! 1436 1186 ! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency 1437 IF( ncom_dttrc /= 1 ) CALL ctl_stop( 'STOP', 'mpp_report, ncom_dttrc /= 1 not coded...' )1438 1187 ncom_freq = ncom_fsbc 1439 1188 ! … … 1481 1230 WRITE(numcom,*) ' ' 1482 1231 WRITE(numcom,*) ' lbc_lnk called' 1483 jj = 1 1484 DO ji = 2, n_sequence_lbc 1485 IF( crname_lbc(ji-1) /= crname_lbc(ji) ) THEN 1486 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(ji-1)) 1487 jj = 0 1232 DO ji = 1, n_sequence_lbc - 1 1233 IF ( crname_lbc(ji) /= 'already counted' ) THEN 1234 ccountname = crname_lbc(ji) 1235 crname_lbc(ji) = 'already counted' 1236 jcount = 1 1237 DO jj = ji + 1, n_sequence_lbc 1238 IF ( ccountname == crname_lbc(jj) ) THEN 1239 jcount = jcount + 1 1240 crname_lbc(jj) = 'already counted' 1241 END IF 1242 END DO 1243 WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname) 1488 1244 END IF 1489 jj = jj + 11490 1245 END DO 1491 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) 1246 IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN 1247 WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(ncom_rec_max)) 1248 END IF 1492 1249 WRITE(numcom,*) ' ' 1493 1250 IF ( n_sequence_glb > 0 ) THEN … … 1528 1285 DEALLOCATE(crname_lbc) 1529 1286 ENDIF 1287 #endif 1530 1288 END SUBROUTINE mpp_report 1289 1531 1290 1532 #else 1533 !!---------------------------------------------------------------------- 1534 !! Default case: Dummy module share memory computing 1535 !!---------------------------------------------------------------------- 1536 USE in_out_manager 1537 1538 INTERFACE mpp_sum 1539 MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 1540 END INTERFACE 1541 INTERFACE mpp_max 1542 MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 1543 END INTERFACE 1544 INTERFACE mpp_min 1545 MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 1546 END INTERFACE 1547 INTERFACE mpp_minloc 1548 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 1549 END INTERFACE 1550 INTERFACE mpp_maxloc 1551 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 1552 END INTERFACE 1553 1554 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 1555 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 1556 INTEGER, PUBLIC :: mpi_comm_oce ! opa local communicator 1557 1558 INTEGER, PARAMETER, PUBLIC :: nbdelay = 0 ! make sure we don't enter loops: DO ji = 1, nbdelay 1559 CHARACTER(len=32), DIMENSION(1), PUBLIC :: c_delaylist = 'empty' 1560 CHARACTER(len=32), DIMENSION(1), PUBLIC :: c_delaycpnt = 'empty' 1561 LOGICAL, PUBLIC :: l_full_nf_update = .TRUE. 1562 TYPE :: DELAYARR 1563 REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL() 1564 COMPLEX(wp), POINTER, DIMENSION(:) :: y1d => NULL() 1565 END TYPE DELAYARR 1566 TYPE( DELAYARR ), DIMENSION(1), PUBLIC :: todelay 1567 INTEGER, PUBLIC, DIMENSION(1) :: ndelayid = -1 1568 !!---------------------------------------------------------------------- 1569 CONTAINS 1570 1571 INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function 1572 INTEGER, INTENT(in) :: kumout 1573 lib_mpp_alloc = 0 1574 END FUNCTION lib_mpp_alloc 1575 1576 FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value) 1577 INTEGER, OPTIONAL , INTENT(in ) :: localComm 1578 CHARACTER(len=*),DIMENSION(:) :: ldtxt 1579 CHARACTER(len=*) :: ldname 1580 INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop 1581 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 1582 function_value = 0 1583 IF( .FALSE. ) ldtxt(:) = 'never done' 1584 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 1585 END FUNCTION mynode 1586 1587 SUBROUTINE mppsync ! Dummy routine 1588 END SUBROUTINE mppsync 1589 1590 !!---------------------------------------------------------------------- 1591 !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** 1592 !! 1593 !!---------------------------------------------------------------------- 1594 !! 1595 # define OPERATION_MAX 1596 # define INTEGER_TYPE 1597 # define DIM_0d 1598 # define ROUTINE_ALLREDUCE mppmax_int 1599 # include "mpp_allreduce_generic.h90" 1600 # undef ROUTINE_ALLREDUCE 1601 # undef DIM_0d 1602 # define DIM_1d 1603 # define ROUTINE_ALLREDUCE mppmax_a_int 1604 # include "mpp_allreduce_generic.h90" 1605 # undef ROUTINE_ALLREDUCE 1606 # undef DIM_1d 1607 # undef INTEGER_TYPE 1608 ! 1609 # define REAL_TYPE 1610 # define DIM_0d 1611 # define ROUTINE_ALLREDUCE mppmax_real 1612 # include "mpp_allreduce_generic.h90" 1613 # undef ROUTINE_ALLREDUCE 1614 # undef DIM_0d 1615 # define DIM_1d 1616 # define ROUTINE_ALLREDUCE mppmax_a_real 1617 # include "mpp_allreduce_generic.h90" 1618 # undef ROUTINE_ALLREDUCE 1619 # undef DIM_1d 1620 # undef REAL_TYPE 1621 # undef OPERATION_MAX 1622 !!---------------------------------------------------------------------- 1623 !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** 1624 !! 1625 !!---------------------------------------------------------------------- 1626 !! 1627 # define OPERATION_MIN 1628 # define INTEGER_TYPE 1629 # define DIM_0d 1630 # define ROUTINE_ALLREDUCE mppmin_int 1631 # include "mpp_allreduce_generic.h90" 1632 # undef ROUTINE_ALLREDUCE 1633 # undef DIM_0d 1634 # define DIM_1d 1635 # define ROUTINE_ALLREDUCE mppmin_a_int 1636 # include "mpp_allreduce_generic.h90" 1637 # undef ROUTINE_ALLREDUCE 1638 # undef DIM_1d 1639 # undef INTEGER_TYPE 1640 ! 1641 # define REAL_TYPE 1642 # define DIM_0d 1643 # define ROUTINE_ALLREDUCE mppmin_real 1644 # include "mpp_allreduce_generic.h90" 1645 # undef ROUTINE_ALLREDUCE 1646 # undef DIM_0d 1647 # define DIM_1d 1648 # define ROUTINE_ALLREDUCE mppmin_a_real 1649 # include "mpp_allreduce_generic.h90" 1650 # undef ROUTINE_ALLREDUCE 1651 # undef DIM_1d 1652 # undef REAL_TYPE 1653 # undef OPERATION_MIN 1654 1655 !!---------------------------------------------------------------------- 1656 !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** 1657 !! 1658 !! Global sum of 1D array or a variable (integer, real or complex) 1659 !!---------------------------------------------------------------------- 1660 !! 1661 # define OPERATION_SUM 1662 # define INTEGER_TYPE 1663 # define DIM_0d 1664 # define ROUTINE_ALLREDUCE mppsum_int 1665 # include "mpp_allreduce_generic.h90" 1666 # undef ROUTINE_ALLREDUCE 1667 # undef DIM_0d 1668 # define DIM_1d 1669 # define ROUTINE_ALLREDUCE mppsum_a_int 1670 # include "mpp_allreduce_generic.h90" 1671 # undef ROUTINE_ALLREDUCE 1672 # undef DIM_1d 1673 # undef INTEGER_TYPE 1674 ! 1675 # define REAL_TYPE 1676 # define DIM_0d 1677 # define ROUTINE_ALLREDUCE mppsum_real 1678 # include "mpp_allreduce_generic.h90" 1679 # undef ROUTINE_ALLREDUCE 1680 # undef DIM_0d 1681 # define DIM_1d 1682 # define ROUTINE_ALLREDUCE mppsum_a_real 1683 # include "mpp_allreduce_generic.h90" 1684 # undef ROUTINE_ALLREDUCE 1685 # undef DIM_1d 1686 # undef REAL_TYPE 1687 # undef OPERATION_SUM 1688 1689 # define OPERATION_SUM_DD 1690 # define COMPLEX_TYPE 1691 # define DIM_0d 1692 # define ROUTINE_ALLREDUCE mppsum_realdd 1693 # include "mpp_allreduce_generic.h90" 1694 # undef ROUTINE_ALLREDUCE 1695 # undef DIM_0d 1696 # define DIM_1d 1697 # define ROUTINE_ALLREDUCE mppsum_a_realdd 1698 # include "mpp_allreduce_generic.h90" 1699 # undef ROUTINE_ALLREDUCE 1700 # undef DIM_1d 1701 # undef COMPLEX_TYPE 1702 # undef OPERATION_SUM_DD 1703 1704 !!---------------------------------------------------------------------- 1705 !! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 1706 !! 1707 !!---------------------------------------------------------------------- 1708 !! 1709 # define OPERATION_MINLOC 1710 # define DIM_2d 1711 # define ROUTINE_LOC mpp_minloc2d 1712 # include "mpp_loc_generic.h90" 1713 # undef ROUTINE_LOC 1714 # undef DIM_2d 1715 # define DIM_3d 1716 # define ROUTINE_LOC mpp_minloc3d 1717 # include "mpp_loc_generic.h90" 1718 # undef ROUTINE_LOC 1719 # undef DIM_3d 1720 # undef OPERATION_MINLOC 1721 1722 # define OPERATION_MAXLOC 1723 # define DIM_2d 1724 # define ROUTINE_LOC mpp_maxloc2d 1725 # include "mpp_loc_generic.h90" 1726 # undef ROUTINE_LOC 1727 # undef DIM_2d 1728 # define DIM_3d 1729 # define ROUTINE_LOC mpp_maxloc3d 1730 # include "mpp_loc_generic.h90" 1731 # undef ROUTINE_LOC 1732 # undef DIM_3d 1733 # undef OPERATION_MAXLOC 1734 1735 SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom ) 1736 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1737 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 1738 COMPLEX(wp), INTENT(in ), DIMENSION(:) :: y_in 1739 REAL(wp), INTENT( out), DIMENSION(:) :: pout 1740 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine 1741 INTEGER, INTENT(in ), OPTIONAL :: kcom 1742 ! 1743 pout(:) = REAL(y_in(:), wp) 1744 END SUBROUTINE mpp_delay_sum 1745 1746 SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) 1747 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1748 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 1749 REAL(wp), INTENT(in ), DIMENSION(:) :: p_in 1750 REAL(wp), INTENT( out), DIMENSION(:) :: pout 1751 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine 1752 INTEGER, INTENT(in ), OPTIONAL :: kcom 1753 ! 1754 pout(:) = p_in(:) 1755 END SUBROUTINE mpp_delay_max 1756 1757 SUBROUTINE mpp_delay_rcv( kid ) 1758 INTEGER,INTENT(in ) :: kid 1759 WRITE(*,*) 'mpp_delay_rcv: You should not have seen this print! error?', kid 1760 END SUBROUTINE mpp_delay_rcv 1291 SUBROUTINE tic_tac (ld_tic, ld_global) 1292 1293 LOGICAL, INTENT(IN) :: ld_tic 1294 LOGICAL, OPTIONAL, INTENT(IN) :: ld_global 1295 REAL(dp), DIMENSION(2), SAVE :: tic_wt 1296 REAL(dp), SAVE :: tic_ct = 0._dp 1297 INTEGER :: ii 1298 #if defined key_mpp_mpi 1299 1300 IF( ncom_stp <= nit000 ) RETURN 1301 IF( ncom_stp == nitend ) RETURN 1302 ii = 1 1303 IF( PRESENT( ld_global ) ) THEN 1304 IF( ld_global ) ii = 2 1305 END IF 1306 1307 IF ( ld_tic ) THEN 1308 tic_wt(ii) = MPI_Wtime() ! start count tic->tac (waiting time) 1309 IF ( tic_ct > 0.0_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic 1310 ELSE 1311 waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii) ! cumulate count tic->tac 1312 tic_ct = MPI_Wtime() ! start count tac->tic (waiting time) 1313 ENDIF 1314 #endif 1315 1316 END SUBROUTINE tic_tac 1317 1318 #if ! defined key_mpp_mpi 1319 SUBROUTINE mpi_wait(request, status, ierror) 1320 INTEGER , INTENT(in ) :: request 1321 INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT( out) :: status 1322 INTEGER , INTENT( out) :: ierror 1323 END SUBROUTINE mpi_wait 1324 1761 1325 1762 SUBROUTINE mppstop( ldfinal, ld_force_abort ) 1763 LOGICAL, OPTIONAL, INTENT(in) :: ldfinal ! source process number 1764 LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort ! source process number 1765 STOP ! non MPP case, just stop the run 1766 END SUBROUTINE mppstop 1767 1768 SUBROUTINE mpp_ini_znl( knum ) 1769 INTEGER :: knum 1770 WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum 1771 END SUBROUTINE mpp_ini_znl 1772 1773 SUBROUTINE mpp_comm_free( kcom ) 1774 INTEGER :: kcom 1775 WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 1776 END SUBROUTINE mpp_comm_free 1777 1778 #endif 1779 1780 !!---------------------------------------------------------------------- 1781 !! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines 1326 FUNCTION MPI_Wtime() 1327 REAL(wp) :: MPI_Wtime 1328 MPI_Wtime = -1. 1329 END FUNCTION MPI_Wtime 1330 #endif 1331 1332 !!---------------------------------------------------------------------- 1333 !! ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam, load_nml routines 1782 1334 !!---------------------------------------------------------------------- 1783 1335 … … 1790 1342 !! increment the error number (nstop) by one. 1791 1343 !!---------------------------------------------------------------------- 1792 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 1793 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1344 CHARACTER(len=*), INTENT(in ) :: cd1 1345 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5 1346 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1347 ! 1348 CHARACTER(LEN=8) :: clfmt ! writing format 1349 INTEGER :: inum 1794 1350 !!---------------------------------------------------------------------- 1795 1351 ! 1796 1352 nstop = nstop + 1 1797 1798 ! force to open ocean.output file 1799 IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 1800 1801 WRITE(numout,cform_err) 1802 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1353 ! 1354 IF( cd1 == 'STOP' .AND. narea /= 1 ) THEN ! Immediate stop: add an arror message in 'ocean.output' file 1355 CALL ctl_opn( inum, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 1356 WRITE(inum,*) 1357 WRITE(inum,*) ' ==>>> Look for "E R R O R" messages in all existing *ocean.output* files' 1358 CLOSE(inum) 1359 ENDIF 1360 IF( numout == 6 ) THEN ! force to open ocean.output file if not already opened 1361 CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) 1362 ENDIF 1363 ! 1364 WRITE(numout,*) 1365 WRITE(numout,*) ' ===>>> : E R R O R' 1366 WRITE(numout,*) 1367 WRITE(numout,*) ' ===========' 1368 WRITE(numout,*) 1369 WRITE(numout,*) TRIM(cd1) 1803 1370 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1804 1371 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) … … 1810 1377 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1811 1378 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1812 1379 WRITE(numout,*) 1380 ! 1813 1381 CALL FLUSH(numout ) 1814 1382 IF( numstp /= -1 ) CALL FLUSH(numstp ) 1815 1383 IF( numrun /= -1 ) CALL FLUSH(numrun ) 1384 IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice) 1816 1385 ! 1817 1386 IF( cd1 == 'STOP' ) THEN 1387 WRITE(numout,*) 1818 1388 WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' 1819 CALL mppstop(ld_force_abort = .true.) 1389 WRITE(numout,*) 1390 CALL FLUSH(numout) 1391 CALL SLEEP(60) ! make sure that all output and abort files are written by all cores. 60s should be enough... 1392 CALL mppstop( ld_abort = .true. ) 1820 1393 ENDIF 1821 1394 ! … … 1836 1409 ! 1837 1410 nwarn = nwarn + 1 1411 ! 1838 1412 IF(lwp) THEN 1839 WRITE(numout,cform_war) 1840 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1841 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1842 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 1843 IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 1844 IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 1845 IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 1846 IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 1847 IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 1848 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1849 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1413 WRITE(numout,*) 1414 WRITE(numout,*) ' ===>>> : W A R N I N G' 1415 WRITE(numout,*) 1416 WRITE(numout,*) ' ===============' 1417 WRITE(numout,*) 1418 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1419 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1420 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 1421 IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 1422 IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 1423 IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 1424 IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 1425 IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 1426 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1427 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1428 WRITE(numout,*) 1850 1429 ENDIF 1851 1430 CALL FLUSH(numout) … … 1873 1452 ! 1874 1453 CHARACTER(len=80) :: clfile 1454 CHARACTER(LEN=10) :: clfmt ! writing format 1875 1455 INTEGER :: iost 1456 INTEGER :: idg ! number of digits 1876 1457 !!---------------------------------------------------------------------- 1877 1458 ! … … 1880 1461 clfile = TRIM(cdfile) 1881 1462 IF( PRESENT( karea ) ) THEN 1882 IF( karea > 1 ) WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1 1463 IF( karea > 1 ) THEN 1464 ! Warning: jpnij is maybe not already defined when calling ctl_opn -> use mppsize instead of jpnij 1465 idg = MAX( INT(LOG10(REAL(MAX(1,mppsize-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 1466 WRITE(clfmt, "('(a,a,i', i1, '.', i1, ')')") idg, idg ! '(a,a,ix.x)' 1467 WRITE(clfile, clfmt) TRIM(clfile), '_', karea-1 1468 ENDIF 1883 1469 ENDIF 1884 1470 #if defined key_agrif … … 1890 1476 IF( TRIM(cdfile) == '/dev/null' ) clfile = TRIM(cdfile) ! force the use of /dev/null 1891 1477 ! 1892 iost=0 1893 IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters 1478 IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters 1894 1479 OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh , ERR=100, IOSTAT=iost ) 1895 1480 ELSE IF( TRIM(cdstat) == 'APPEND' ) THEN ! cdstat can have less than 6 characters … … 1901 1486 & OPEN(UNIT=knum,FILE='NUL', FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost ) 1902 1487 IF( iost == 0 ) THEN 1903 IF(ldwp ) THEN1488 IF(ldwp .AND. kout > 0) THEN 1904 1489 WRITE(kout,*) ' file : ', TRIM(clfile),' open ok' 1905 1490 WRITE(kout,*) ' unit = ', knum … … 1912 1497 100 CONTINUE 1913 1498 IF( iost /= 0 ) THEN 1914 IF(ldwp) THEN 1915 WRITE(kout,*) 1916 WRITE(kout,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 1917 WRITE(kout,*) ' ======= === ' 1918 WRITE(kout,*) ' unit = ', knum 1919 WRITE(kout,*) ' status = ', cdstat 1920 WRITE(kout,*) ' form = ', cdform 1921 WRITE(kout,*) ' access = ', cdacce 1922 WRITE(kout,*) ' iostat = ', iost 1923 WRITE(kout,*) ' we stop. verify the file ' 1924 WRITE(kout,*) 1925 ELSE !!! Force writing to make sure we get the information - at least once - in this violent STOP!! 1926 WRITE(*,*) 1927 WRITE(*,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 1928 WRITE(*,*) ' ======= === ' 1929 WRITE(*,*) ' unit = ', knum 1930 WRITE(*,*) ' status = ', cdstat 1931 WRITE(*,*) ' form = ', cdform 1932 WRITE(*,*) ' access = ', cdacce 1933 WRITE(*,*) ' iostat = ', iost 1934 WRITE(*,*) ' we stop. verify the file ' 1935 WRITE(*,*) 1936 ENDIF 1937 CALL FLUSH( kout ) 1938 STOP 'ctl_opn bad opening' 1499 WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 1500 WRITE(ctmp2,*) ' ======= === ' 1501 WRITE(ctmp3,*) ' unit = ', knum 1502 WRITE(ctmp4,*) ' status = ', cdstat 1503 WRITE(ctmp5,*) ' form = ', cdform 1504 WRITE(ctmp6,*) ' access = ', cdacce 1505 WRITE(ctmp7,*) ' iostat = ', iost 1506 WRITE(ctmp8,*) ' we stop. verify the file ' 1507 CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 1939 1508 ENDIF 1940 1509 ! … … 1942 1511 1943 1512 1944 SUBROUTINE ctl_nam ( kios, cdnam , ldwp)1513 SUBROUTINE ctl_nam ( kios, cdnam ) 1945 1514 !!---------------------------------------------------------------------- 1946 1515 !! *** ROUTINE ctl_nam *** … … 1950 1519 !! ** Method : Fortan open 1951 1520 !!---------------------------------------------------------------------- 1952 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist1953 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs1954 CHARACTER(len=5) :: clios ! string to convert iostat in character for print1955 LOGICAL , INTENT(in ) :: ldwp ! boolean termfor print1521 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 1522 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs 1523 ! 1524 CHARACTER(len=5) :: clios ! string to convert iostat in character for print 1956 1525 !!---------------------------------------------------------------------- 1957 1526 ! … … 1967 1536 ENDIF 1968 1537 kios = 0 1969 RETURN1970 1538 ! 1971 1539 END SUBROUTINE ctl_nam … … 1988 1556 END DO 1989 1557 IF( (get_unit == 999) .AND. llopn ) THEN 1990 CALL ctl_stop( 'get_unit: All logical units until 999 are used...' ) 1991 get_unit = -1 1558 CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' ) 1992 1559 ENDIF 1993 1560 ! 1994 1561 END FUNCTION get_unit 1995 1562 1563 SUBROUTINE load_nml( cdnambuff , cdnamfile, kout, ldwp) 1564 CHARACTER(LEN=:) , ALLOCATABLE, INTENT(INOUT) :: cdnambuff 1565 CHARACTER(LEN=*), INTENT(IN ) :: cdnamfile 1566 CHARACTER(LEN=256) :: chline 1567 CHARACTER(LEN=1) :: csp 1568 INTEGER, INTENT(IN) :: kout 1569 LOGICAL, INTENT(IN) :: ldwp !: .true. only for the root broadcaster 1570 INTEGER :: itot, iun, iltc, inl, ios, itotsav 1571 ! 1572 !csp = NEW_LINE('A') 1573 ! a new line character is the best seperator but some systems (e.g.Cray) 1574 ! seem to terminate namelist reads from internal files early if they 1575 ! encounter new-lines. Use a single space for safety. 1576 csp = ' ' 1577 ! 1578 ! Check if the namelist buffer has already been allocated. Return if it has. 1579 ! 1580 IF ( ALLOCATED( cdnambuff ) ) RETURN 1581 IF( ldwp ) THEN 1582 ! 1583 ! Open namelist file 1584 ! 1585 CALL ctl_opn( iun, cdnamfile, 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, kout, ldwp ) 1586 ! 1587 ! First pass: count characters excluding comments and trimable white space 1588 ! 1589 itot=0 1590 10 READ(iun,'(A256)',END=20,ERR=20) chline 1591 iltc = LEN_TRIM(chline) 1592 IF ( iltc.GT.0 ) THEN 1593 inl = INDEX(chline, '!') 1594 IF( inl.eq.0 ) THEN 1595 itot = itot + iltc + 1 ! +1 for the newline character 1596 ELSEIF( inl.GT.0 .AND. LEN_TRIM( chline(1:inl-1) ).GT.0 ) THEN 1597 itot = itot + inl ! includes +1 for the newline character 1598 ENDIF 1599 ENDIF 1600 GOTO 10 1601 20 CONTINUE 1602 ! 1603 ! Allocate text cdnambuff for condensed namelist 1604 ! 1605 !$AGRIF_DO_NOT_TREAT 1606 ALLOCATE( CHARACTER(LEN=itot) :: cdnambuff ) 1607 !$AGRIF_END_DO_NOT_TREAT 1608 itotsav = itot 1609 ! 1610 ! Second pass: read and transfer pruned characters into cdnambuff 1611 ! 1612 REWIND(iun) 1613 itot=1 1614 30 READ(iun,'(A256)',END=40,ERR=40) chline 1615 iltc = LEN_TRIM(chline) 1616 IF ( iltc.GT.0 ) THEN 1617 inl = INDEX(chline, '!') 1618 IF( inl.eq.0 ) THEN 1619 inl = iltc 1620 ELSE 1621 inl = inl - 1 1622 ENDIF 1623 IF( inl.GT.0 .AND. LEN_TRIM( chline(1:inl) ).GT.0 ) THEN 1624 cdnambuff(itot:itot+inl-1) = chline(1:inl) 1625 WRITE( cdnambuff(itot+inl:itot+inl), '(a)' ) csp 1626 itot = itot + inl + 1 1627 ENDIF 1628 ENDIF 1629 GOTO 30 1630 40 CONTINUE 1631 itot = itot - 1 1632 IF( itotsav .NE. itot ) WRITE(*,*) 'WARNING in load_nml. Allocated ',itotsav,' for read buffer; but used ',itot 1633 ! 1634 ! Close namelist file 1635 ! 1636 CLOSE(iun) 1637 !write(*,'(32A)') cdnambuff 1638 ENDIF 1639 #if defined key_mpp_mpi 1640 CALL mpp_bcast_nml( cdnambuff, itot ) 1641 #endif 1642 END SUBROUTINE load_nml 1643 1644 1996 1645 !!---------------------------------------------------------------------- 1997 1646 END MODULE lib_mpp -
utils/tools/DOMAINcfg/src/mpp_allreduce_generic.h90
r13204 r14623 1 1 ! !== IN: ptab is an array ==! 2 2 # if defined REAL_TYPE 3 # define ARRAY_TYPE(i) REAL(wp) , INTENT(inout) :: ARRAY_IN(i) 4 # define TMP_TYPE(i) REAL(wp) , ALLOCATABLE :: work(i) 5 # define MPI_TYPE mpi_double_precision 3 # if defined SINGLE_PRECISION 4 # define ARRAY_TYPE(i) REAL(sp) , INTENT(inout) :: ARRAY_IN(i) 5 # define TMP_TYPE(i) REAL(sp) , ALLOCATABLE :: work(i) 6 # define MPI_TYPE mpi_real 7 # else 8 # define ARRAY_TYPE(i) REAL(dp) , INTENT(inout) :: ARRAY_IN(i) 9 # define TMP_TYPE(i) REAL(dp) , ALLOCATABLE :: work(i) 10 # define MPI_TYPE mpi_double_precision 11 # endif 6 12 # endif 7 13 # if defined INTEGER_TYPE … … 11 17 # endif 12 18 # if defined COMPLEX_TYPE 13 # define ARRAY_TYPE(i) COMPLEX 14 # define TMP_TYPE(i) COMPLEX 19 # define ARRAY_TYPE(i) COMPLEX(dp) , INTENT(inout) :: ARRAY_IN(i) 20 # define TMP_TYPE(i) COMPLEX(dp) , ALLOCATABLE :: work(i) 15 21 # define MPI_TYPE mpi_double_complex 16 22 # endif … … 61 67 ! 62 68 ALLOCATE(work(ipi)) 69 IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) 63 70 CALL mpi_allreduce( ARRAY_IN(:), work, ipi, MPI_TYPE, MPI_OPERATION, ilocalcomm, ierror ) 71 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 64 72 DO ii = 1, ipi 65 73 ARRAY_IN(ii) = work(ii) … … 73 81 END SUBROUTINE ROUTINE_ALLREDUCE 74 82 83 #undef PRECISION 75 84 #undef ARRAY_TYPE 76 85 #undef ARRAY_IN -
utils/tools/DOMAINcfg/src/mpp_lnk_generic.h90
r13204 r14623 5 5 # define OPT_K(k) ,ipf 6 6 # if defined DIM_2d 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f) 7 # if defined SINGLE_PRECISION 8 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) 9 # else 10 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) 11 # endif 8 12 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 9 13 # define K_SIZE(ptab) 1 … … 11 15 # endif 12 16 # if defined DIM_3d 13 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f) 17 # if defined SINGLE_PRECISION 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) 19 # else 20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) 21 # endif 14 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 15 23 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) … … 17 25 # endif 18 26 # if defined DIM_4d 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f) 27 # if defined SINGLE_PRECISION 28 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) 29 # else 30 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) 31 # endif 20 32 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 21 33 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) … … 23 35 # endif 24 36 #else 25 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 37 # if defined SINGLE_PRECISION 38 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 39 # else 40 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 41 # endif 26 42 # define NAT_IN(k) cd_nat 27 43 # define SGN_IN(k) psgn … … 45 61 #endif 46 62 63 # if defined SINGLE_PRECISION 64 # define PRECISION sp 65 # define SENDROUTINE mppsend_sp 66 # define RECVROUTINE mpprecv_sp 67 # else 68 # define PRECISION dp 69 # define SENDROUTINE mppsend_dp 70 # define RECVROUTINE mpprecv_dp 71 # endif 72 47 73 #if defined MULTI 48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, cd_mpp, pval)49 INTEGER 74 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv ) 75 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 50 76 #else 51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , cd_mpp, pval)77 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv ) 52 78 #endif 53 79 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 54 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 55 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 56 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 57 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 58 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 59 ! 60 INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices 80 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 82 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 83 INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 84 REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 85 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 86 ! 87 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 61 88 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 62 INTEGER :: i migr, iihom, ijhom! local integers63 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend89 INTEGER :: isize, ishift, ishift2 ! local integers 90 INTEGER :: ireq_we, ireq_ea, ireq_so, ireq_no ! mpi_request id 64 91 INTEGER :: ierr 92 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 65 93 REAL(wp) :: zland 66 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 67 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! north-south & south-north halos 68 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! east -west & west - east halos 94 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 95 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos 96 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos 97 LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send 98 LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive 99 LOGICAL :: lldo_nfd ! do north pole folding 69 100 !!---------------------------------------------------------------------- 101 ! 102 ! ----------------------------------------- ! 103 ! 0. local variables initialization ! 104 ! ----------------------------------------- ! 70 105 ! 71 106 ipk = K_SIZE(ptab) ! 3rd dimension … … 75 110 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 76 111 ! 77 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 78 ELSE ; zland = 0._wp ! zero by default 79 ENDIF 112 IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN 113 llsend_we = lsend(1) ; llsend_ea = lsend(2) ; llsend_so = lsend(3) ; llsend_no = lsend(4) 114 llrecv_we = lrecv(1) ; llrecv_ea = lrecv(2) ; llrecv_so = lrecv(3) ; llrecv_no = lrecv(4) 115 ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN 116 WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' 117 WRITE(ctmp2,*) ' ========== ' 118 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 119 ELSE ! send and receive with every neighbour 120 llsend_we = nbondi == 1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 121 llsend_ea = nbondi == -1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini 122 llsend_so = nbondj == 1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 123 llsend_no = nbondj == -1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini 124 llrecv_we = llsend_we ; llrecv_ea = llsend_ea ; llrecv_so = llsend_so ; llrecv_no = llsend_no 125 END IF 126 127 128 lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini 80 129 81 ! ------------------------------- ! 82 ! standard boundary treatment ! ! CAUTION: semi-column notation is often impossible 83 ! ------------------------------- ! 84 ! 85 IF( .NOT. PRESENT( cd_mpp ) ) THEN !== standard close or cyclic treatment ==! 86 ! 87 DO jf = 1, ipf ! number of arrays to be treated 88 ! 89 ! ! East-West boundaries 90 IF( l_Iperio ) THEN !* cyclic 91 ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf) 92 ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN( 2 ,:,:,:,jf) 93 ELSE !* closed 94 IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN( 1 :nn_hls,:,:,:,jf) = zland ! east except F-point 95 ARRAY_IN(nlci-nn_hls+1:jpi ,:,:,:,jf) = zland ! west 96 ENDIF 97 ! ! North-South boundaries 98 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) 99 ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf) 100 ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:, 2 ,:,:,jf) 101 ELSE !* closed 102 IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN(:, 1 :nn_hls,:,:,jf) = zland ! south except F-point 103 ARRAY_IN(:,nlcj-nn_hls+1:jpj ,:,:,jf) = zland ! north 104 ENDIF 105 END DO 106 ! 107 ENDIF 130 zland = 0._wp ! land filling value: zero by default 131 IF( PRESENT( pfillval ) ) zland = pfillval ! set land value 108 132 109 ! ------------------------------- ! 110 ! East and west exchange ! 111 ! ------------------------------- ! 112 ! we play with the neigbours AND the row number because of the periodicity 113 ! 114 IF( ABS(nbondi) == 1 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,1), zt3we(jpj,nn_hls,ipk,ipl,ipf,1) ) 115 IF( nbondi == 0 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2) ) 116 ! 117 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 118 CASE ( -1 ) 119 iihom = nlci-nreci 120 DO jf = 1, ipf 121 DO jl = 1, ipl 122 DO jk = 1, ipk 123 DO jh = 1, nn_hls 124 zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 125 END DO 126 END DO 127 END DO 128 END DO 129 CASE ( 0 ) 130 iihom = nlci-nreci 131 DO jf = 1, ipf 132 DO jl = 1, ipl 133 DO jk = 1, ipk 134 DO jh = 1, nn_hls 135 zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 136 zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 137 END DO 138 END DO 139 END DO 140 END DO 141 CASE ( 1 ) 142 iihom = nlci-nreci 143 DO jf = 1, ipf 144 DO jl = 1, ipl 145 DO jk = 1, ipk 146 DO jh = 1, nn_hls 147 zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 148 END DO 149 END DO 150 END DO 151 END DO 133 ! define the method we will use to fill the halos in each direction 134 IF( llrecv_we ) THEN ; ifill_we = jpfillmpi 135 ELSEIF( l_Iperio ) THEN ; ifill_we = jpfillperio 136 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_we = kfillmode 137 ELSE ; ifill_we = jpfillcst 138 END IF 139 ! 140 IF( llrecv_ea ) THEN ; ifill_ea = jpfillmpi 141 ELSEIF( l_Iperio ) THEN ; ifill_ea = jpfillperio 142 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_ea = kfillmode 143 ELSE ; ifill_ea = jpfillcst 144 END IF 145 ! 146 IF( llrecv_so ) THEN ; ifill_so = jpfillmpi 147 ELSEIF( l_Jperio ) THEN ; ifill_so = jpfillperio 148 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_so = kfillmode 149 ELSE ; ifill_so = jpfillcst 150 END IF 151 ! 152 IF( llrecv_no ) THEN ; ifill_no = jpfillmpi 153 ELSEIF( l_Jperio ) THEN ; ifill_no = jpfillperio 154 ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_no = kfillmode 155 ELSE ; ifill_no = jpfillcst 156 END IF 157 ! 158 #if defined PRINT_CAUTION 159 ! 160 ! ================================================================================== ! 161 ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! 162 ! ================================================================================== ! 163 ! 164 #endif 165 ! 166 ! -------------------------------------------------- ! 167 ! 1. Do east and west MPI exchange if needed ! 168 ! -------------------------------------------------- ! 169 ! 170 ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 171 isize = nn_hls * jpj * ipk * ipl * ipf 172 ! 173 ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 174 IF( llsend_we ) ALLOCATE( zsnd_we(nn_hls,jpj,ipk,ipl,ipf) ) 175 IF( llsend_ea ) ALLOCATE( zsnd_ea(nn_hls,jpj,ipk,ipl,ipf) ) 176 IF( llrecv_we ) ALLOCATE( zrcv_we(nn_hls,jpj,ipk,ipl,ipf) ) 177 IF( llrecv_ea ) ALLOCATE( zrcv_ea(nn_hls,jpj,ipk,ipl,ipf) ) 178 ! 179 IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 180 ishift = nn_hls 181 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 182 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! nn_hls + 1 -> 2*nn_hls 183 END DO ; END DO ; END DO ; END DO ; END DO 184 ENDIF 185 ! 186 IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 187 ishift = jpi - 2 * nn_hls 188 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 189 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*nn_hls + 1 -> jpi - nn_hls 190 END DO ; END DO ; END DO ; END DO ; END DO 191 ENDIF 192 ! 193 IF( ln_timing ) CALL tic_tac(.TRUE.) 194 ! 195 ! non-blocking send of the western/eastern side using local temporary arrays 196 IF( llsend_we ) CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 197 IF( llsend_ea ) CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 198 ! blocking receive of the western/eastern halo in local temporary arrays 199 IF( llrecv_we ) CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 200 IF( llrecv_ea ) CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 201 ! 202 IF( ln_timing ) CALL tic_tac(.FALSE.) 203 ! 204 ! 205 ! ----------------------------------- ! 206 ! 2. Fill east and west halos ! 207 ! ----------------------------------- ! 208 ! 209 ! 2.1 fill weastern halo 210 ! ---------------------- 211 ! ishift = 0 ! fill halo from ji = 1 to nn_hls 212 SELECT CASE ( ifill_we ) 213 CASE ( jpfillnothing ) ! no filling 214 CASE ( jpfillmpi ) ! use data received by MPI 215 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 216 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> nn_hls 217 END DO ; END DO ; END DO ; END DO ; END DO 218 CASE ( jpfillperio ) ! use east-weast periodicity 219 ishift2 = jpi - 2 * nn_hls 220 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 221 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 222 END DO ; END DO ; END DO ; END DO ; END DO 223 CASE ( jpfillcopy ) ! filling with inner domain values 224 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 225 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf) 226 END DO ; END DO ; END DO ; END DO ; END DO 227 CASE ( jpfillcst ) ! filling with constant value 228 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 229 ARRAY_IN(ji,jj,jk,jl,jf) = zland 230 END DO ; END DO ; END DO ; END DO ; END DO 152 231 END SELECT 153 ! ! Migrations 154 imigr = nn_hls * jpj * ipk * ipl * ipf 155 ! 156 SELECT CASE ( nbondi ) 157 CASE ( -1 ) 158 CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 ) 159 CALL mpprecv( 1, zt3ew(1,1,1,1,1,1), imigr, noea ) 160 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 161 CASE ( 0 ) 162 CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 163 CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 ) 164 CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea ) 165 CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe ) 166 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 167 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 168 CASE ( 1 ) 169 CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 170 CALL mpprecv( 2, zt3we(1,1,1,1,1,1), imigr, nowe ) 171 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 232 ! 233 ! 2.2 fill eastern halo 234 ! --------------------- 235 ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi 236 SELECT CASE ( ifill_ea ) 237 CASE ( jpfillnothing ) ! no filling 238 CASE ( jpfillmpi ) ! use data received by MPI 239 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 240 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - nn_hls + 1 -> jpi 241 END DO ; END DO ; END DO ; END DO ; END DO 242 CASE ( jpfillperio ) ! use east-weast periodicity 243 ishift2 = nn_hls 244 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 245 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 246 END DO ; END DO ; END DO ; END DO ; END DO 247 CASE ( jpfillcopy ) ! filling with inner domain values 248 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 249 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 250 END DO ; END DO ; END DO ; END DO ; END DO 251 CASE ( jpfillcst ) ! filling with constant value 252 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls 253 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 254 END DO ; END DO ; END DO ; END DO ; END DO 172 255 END SELECT 173 !174 ! ! Write Dirichlet lateral conditions175 iihom = nlci-nn_hls176 !177 SELECT CASE ( nbondi )178 CASE ( -1 )179 DO jf = 1, ipf180 DO jl = 1, ipl181 DO jk = 1, ipk182 DO jh = 1, nn_hls183 ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,1)184 END DO185 END DO186 END DO187 END DO188 CASE ( 0 )189 DO jf = 1, ipf190 DO jl = 1, ipl191 DO jk = 1, ipk192 DO jh = 1, nn_hls193 ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)194 ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)195 END DO196 END DO197 END DO198 END DO199 CASE ( 1 )200 DO jf = 1, ipf201 DO jl = 1, ipl202 DO jk = 1, ipk203 DO jh = 1, nn_hls204 ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,1)205 END DO206 END DO207 END DO208 END DO209 END SELECT210 !211 IF( nbondi /= 2 ) DEALLOCATE( zt3ew, zt3we )212 256 ! 213 257 ! ------------------------------- ! 214 258 ! 3. north fold treatment ! 215 259 ! ------------------------------- ! 260 ! 216 261 ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor 217 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 262 ! 263 IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN 218 264 ! 219 265 SELECT CASE ( jpni ) 220 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp221 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.266 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp 267 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) ) ! for all northern procs. 222 268 END SELECT 223 269 ! 224 ENDIF 225 ! 226 ! ------------------------------- ! 227 ! 4. North and south directions ! 228 ! ------------------------------- ! 229 ! always closed : we play only with the neigbours 230 ! 231 IF( ABS(nbondj) == 1 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,1), zt3sn(jpi,nn_hls,ipk,ipl,ipf,1) ) 232 IF( nbondj == 0 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2) ) 233 ! 234 SELECT CASE ( nbondj ) 235 CASE ( -1 ) 236 ijhom = nlcj-nrecj 237 DO jf = 1, ipf 238 DO jl = 1, ipl 239 DO jk = 1, ipk 240 DO jh = 1, nn_hls 241 zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 242 END DO 243 END DO 244 END DO 245 END DO 246 CASE ( 0 ) 247 ijhom = nlcj-nrecj 248 DO jf = 1, ipf 249 DO jl = 1, ipl 250 DO jk = 1, ipk 251 DO jh = 1, nn_hls 252 zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 253 zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 254 END DO 255 END DO 256 END DO 257 END DO 258 CASE ( 1 ) 259 ijhom = nlcj-nrecj 260 DO jf = 1, ipf 261 DO jl = 1, ipl 262 DO jk = 1, ipk 263 DO jh = 1, nn_hls 264 zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 265 END DO 266 END DO 267 END DO 268 END DO 270 ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding 271 ! 272 ENDIF 273 ! 274 ! ---------------------------------------------------- ! 275 ! 4. Do north and south MPI exchange if needed ! 276 ! ---------------------------------------------------- ! 277 ! 278 IF( llsend_so ) ALLOCATE( zsnd_so(jpi,nn_hls,ipk,ipl,ipf) ) 279 IF( llsend_no ) ALLOCATE( zsnd_no(jpi,nn_hls,ipk,ipl,ipf) ) 280 IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,nn_hls,ipk,ipl,ipf) ) 281 IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,nn_hls,ipk,ipl,ipf) ) 282 ! 283 isize = jpi * nn_hls * ipk * ipl * ipf 284 285 ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 286 IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 287 ishift = nn_hls 288 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 289 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! nn_hls+1 -> 2*nn_hls 290 END DO ; END DO ; END DO ; END DO ; END DO 291 ENDIF 292 ! 293 IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 294 ishift = jpj - 2 * nn_hls 295 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 296 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*nn_hls+1 -> jpj-nn_hls 297 END DO ; END DO ; END DO ; END DO ; END DO 298 ENDIF 299 ! 300 IF( ln_timing ) CALL tic_tac(.TRUE.) 301 ! 302 ! non-blocking send of the southern/northern side 303 IF( llsend_so ) CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 304 IF( llsend_no ) CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 305 ! blocking receive of the southern/northern halo 306 IF( llrecv_so ) CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso ) 307 IF( llrecv_no ) CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono ) 308 ! 309 IF( ln_timing ) CALL tic_tac(.FALSE.) 310 ! 311 ! ------------------------------------- ! 312 ! 5. Fill south and north halos ! 313 ! ------------------------------------- ! 314 ! 315 ! 5.1 fill southern halo 316 ! ---------------------- 317 ! ishift = 0 ! fill halo from jj = 1 to nn_hls 318 SELECT CASE ( ifill_so ) 319 CASE ( jpfillnothing ) ! no filling 320 CASE ( jpfillmpi ) ! use data received by MPI 321 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 322 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> nn_hls 323 END DO ; END DO ; END DO ; END DO ; END DO 324 CASE ( jpfillperio ) ! use north-south periodicity 325 ishift2 = jpj - 2 * nn_hls 326 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 327 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 328 END DO ; END DO ; END DO ; END DO ; END DO 329 CASE ( jpfillcopy ) ! filling with inner domain values 330 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 331 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf) 332 END DO ; END DO ; END DO ; END DO ; END DO 333 CASE ( jpfillcst ) ! filling with constant value 334 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 335 ARRAY_IN(ji,jj,jk,jl,jf) = zland 336 END DO ; END DO ; END DO ; END DO ; END DO 269 337 END SELECT 270 338 ! 271 ! ! Migrations 272 imigr = nn_hls * jpi * ipk * ipl * ipf 273 ! 274 SELECT CASE ( nbondj ) 275 CASE ( -1 ) 276 CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 ) 277 CALL mpprecv( 3, zt3ns(1,1,1,1,1,1), imigr, nono ) 278 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 279 CASE ( 0 ) 280 CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 281 CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 ) 282 CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono ) 283 CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso ) 284 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 285 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err ) 286 CASE ( 1 ) 287 CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 288 CALL mpprecv( 4, zt3sn(1,1,1,1,1,1), imigr, noso ) 289 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 339 ! 5.2 fill northern halo 340 ! ---------------------- 341 ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj 342 SELECT CASE ( ifill_no ) 343 CASE ( jpfillnothing ) ! no filling 344 CASE ( jpfillmpi ) ! use data received by MPI 345 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 346 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-nn_hls+1 -> jpj 347 END DO ; END DO ; END DO ; END DO ; END DO 348 CASE ( jpfillperio ) ! use north-south periodicity 349 ishift2 = nn_hls 350 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 351 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 352 END DO ; END DO ; END DO ; END DO ; END DO 353 CASE ( jpfillcopy ) ! filling with inner domain values 354 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 355 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 356 END DO ; END DO ; END DO ; END DO ; END DO 357 CASE ( jpfillcst ) ! filling with constant value 358 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi 359 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 360 END DO ; END DO ; END DO ; END DO ; END DO 290 361 END SELECT 291 362 ! 292 ijhom = nlcj-nn_hls 293 ! 294 SELECT CASE ( nbondj ) 295 CASE ( -1 ) 296 DO jf = 1, ipf 297 DO jl = 1, ipl 298 DO jk = 1, ipk 299 DO jh = 1, nn_hls 300 ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,1) 301 END DO 302 END DO 303 END DO 304 END DO 305 CASE ( 0 ) 306 DO jf = 1, ipf 307 DO jl = 1, ipl 308 DO jk = 1, ipk 309 DO jh = 1, nn_hls 310 ARRAY_IN(:, jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 311 ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 312 END DO 313 END DO 314 END DO 315 END DO 316 CASE ( 1 ) 317 DO jf = 1, ipf 318 DO jl = 1, ipl 319 DO jk = 1, ipk 320 DO jh = 1, nn_hls 321 ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,1) 322 END DO 323 END DO 324 END DO 325 END DO 326 END SELECT 327 ! 328 IF( nbondj /= 2 ) DEALLOCATE( zt3ns, zt3sn ) 363 ! -------------------------------------------- ! 364 ! 6. deallocate local temporary arrays ! 365 ! -------------------------------------------- ! 366 ! 367 IF( llsend_we ) THEN 368 CALL mpi_wait(ireq_we, istat, ierr ) 369 DEALLOCATE( zsnd_we ) 370 ENDIF 371 IF( llsend_ea ) THEN 372 CALL mpi_wait(ireq_ea, istat, ierr ) 373 DEALLOCATE( zsnd_ea ) 374 ENDIF 375 IF( llsend_so ) THEN 376 CALL mpi_wait(ireq_so, istat, ierr ) 377 DEALLOCATE( zsnd_so ) 378 ENDIF 379 IF( llsend_no ) THEN 380 CALL mpi_wait(ireq_no, istat, ierr ) 381 DEALLOCATE( zsnd_no ) 382 ENDIF 383 ! 384 IF( llrecv_we ) DEALLOCATE( zrcv_we ) 385 IF( llrecv_ea ) DEALLOCATE( zrcv_ea ) 386 IF( llrecv_so ) DEALLOCATE( zrcv_so ) 387 IF( llrecv_no ) DEALLOCATE( zrcv_no ) 329 388 ! 330 389 END SUBROUTINE ROUTINE_LNK 331 390 #undef PRECISION 391 #undef SENDROUTINE 392 #undef RECVROUTINE 332 393 #undef ARRAY_TYPE 333 394 #undef NAT_IN -
utils/tools/DOMAINcfg/src/mpp_loc_generic.h90
r13204 r14623 1 1 !== IN: ptab is an array ==! 2 # define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k) 3 # define MASK_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: MASK_IN(i,j,k) 2 # if defined SINGLE_PRECISION 3 # define ARRAY_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: ARRAY_IN(i,j,k) 4 # define MASK_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: MASK_IN(i,j,k) 5 # define PRECISION sp 6 # else 7 # define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) 8 # define MASK_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: MASK_IN(i,j,k) 9 # define PRECISION dp 10 # endif 11 4 12 # if defined DIM_2d 5 13 # define ARRAY_IN(i,j,k) ptab(i,j) … … 17 25 # define MPI_OPERATION mpi_maxloc 18 26 # define LOC_OPERATION MAXLOC 27 # define ERRVAL -HUGE 19 28 # endif 20 29 # if defined OPERATION_MINLOC 21 30 # define MPI_OPERATION mpi_minloc 22 31 # define LOC_OPERATION MINLOC 32 # define ERRVAL HUGE 23 33 # endif 24 34 … … 28 38 ARRAY_TYPE(:,:,:) ! array on which loctrans operation is applied 29 39 MASK_TYPE(:,:,:) ! local mask 30 REAL( wp) , INTENT( out) :: pmin ! Global minimum of ptab40 REAL(PRECISION) , INTENT( out) :: pmin ! Global minimum of ptab 31 41 INDEX_TYPE(:) ! index of minimum in global frame 32 # if defined key_mpp_mpi33 42 ! 34 43 INTEGER :: ierror, ii, idim 35 44 INTEGER :: index0 36 REAL( wp) :: zmin ! local minimum45 REAL(PRECISION) :: zmin ! local minimum 37 46 INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs 38 REAL( wp), DIMENSION(2,1) :: zain, zaout47 REAL(dp), DIMENSION(2,1) :: zain, zaout 39 48 !!----------------------------------------------------------------------- 40 49 ! … … 42 51 ! 43 52 idim = SIZE(kindex) 44 ALLOCATE ( ilocs(idim) )45 53 ! 46 ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp ) 47 zmin = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3)) 48 ! 49 kindex(1) = ilocs(1) + nimpp - 1 50 # if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 51 kindex(2) = ilocs(2) + njmpp - 1 52 # endif 53 # if defined DIM_3d /* avoid warning when kindex has 2 elements */ 54 kindex(3) = ilocs(3) 55 # endif 56 ! 57 DEALLOCATE (ilocs) 58 ! 59 index0 = kindex(1)-1 ! 1d index starting at 0 60 # if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 61 index0 = index0 + jpiglo * (kindex(2)-1) 62 # endif 63 # if defined DIM_3d /* avoid warning when kindex has 2 elements */ 64 index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) 65 # endif 54 IF ( ALL(MASK_IN(:,:,:) /= 1._wp) ) THEN 55 ! special case for land processors 56 zmin = ERRVAL(zmin) 57 index0 = 0 58 ELSE 59 ALLOCATE ( ilocs(idim) ) 60 ! 61 ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp ) 62 zmin = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3)) 63 ! 64 kindex(1) = mig( ilocs(1) ) 65 #if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 66 kindex(2) = mjg( ilocs(2) ) 67 #endif 68 #if defined DIM_3d /* avoid warning when kindex has 2 elements */ 69 kindex(3) = ilocs(3) 70 #endif 71 ! 72 DEALLOCATE (ilocs) 73 ! 74 index0 = kindex(1)-1 ! 1d index starting at 0 75 #if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 76 index0 = index0 + jpiglo * (kindex(2)-1) 77 #endif 78 #if defined DIM_3d /* avoid warning when kindex has 2 elements */ 79 index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) 80 #endif 81 END IF 66 82 zain(1,:) = zmin 67 83 zain(2,:) = REAL(index0, wp) 68 84 ! 85 IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) 86 #if defined key_mpp_mpi 69 87 CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_OPERATION ,MPI_COMM_OCE, ierror) 88 #else 89 zaout(:,:) = zain(:,:) 90 #endif 91 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 70 92 ! 71 93 pmin = zaout(1,1) 72 94 index0 = NINT( zaout(2,1) ) 73 # 95 #if defined DIM_3d /* avoid warning when kindex has 2 elements */ 74 96 kindex(3) = index0 / (jpiglo*jpjglo) 75 97 index0 = index0 - kindex(3) * (jpiglo*jpjglo) 76 # 77 # 98 #endif 99 #if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 78 100 kindex(2) = index0 / jpiglo 79 101 index0 = index0 - kindex(2) * jpiglo 80 # 102 #endif 81 103 kindex(1) = index0 82 104 kindex(:) = kindex(:) + 1 ! start indices at 1 83 #else84 kindex = 0 ; pmin = 0.85 WRITE(*,*) 'ROUTINE_LOC: You should not have seen this print! error?'86 #endif87 105 88 106 END SUBROUTINE ROUTINE_LOC 89 107 108 109 #undef PRECISION 90 110 #undef ARRAY_TYPE 91 #undef MA X_TYPE111 #undef MASK_TYPE 92 112 #undef ARRAY_IN 93 113 #undef MASK_IN … … 96 116 #undef LOC_OPERATION 97 117 #undef INDEX_TYPE 118 #undef ERRVAL -
utils/tools/DOMAINcfg/src/mpp_nfd_generic.h90
r13204 r14623 5 5 # define LBC_ARG (jf) 6 6 # if defined DIM_2d 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f) 7 # if defined SINGLE_PRECISION 8 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) 9 # else 10 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) 11 # endif 8 12 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 9 13 # define K_SIZE(ptab) 1 … … 11 15 # endif 12 16 # if defined DIM_3d 13 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f) 17 # if defined SINGLE_PRECISION 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) 19 # else 20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) 21 # endif 14 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 15 23 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) … … 17 25 # endif 18 26 # if defined DIM_4d 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f) 27 # if defined SINGLE_PRECISION 28 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) 29 # else 30 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) 31 # endif 20 32 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 21 33 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) … … 24 36 #else 25 37 ! !== IN: ptab is an array ==! 26 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 38 # if defined SINGLE_PRECISION 39 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 40 # else 41 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 42 # endif 27 43 # define NAT_IN(k) cd_nat 28 44 # define SGN_IN(k) psgn … … 46 62 #endif 47 63 48 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) 64 # if defined SINGLE_PRECISION 65 # define PRECISION sp 66 # define SENDROUTINE mppsend_sp 67 # define RECVROUTINE mpprecv_sp 68 # define MPI_TYPE MPI_REAL 69 # define HUGEVAL(x) HUGE(x/**/_sp) 70 # else 71 # define PRECISION dp 72 # define SENDROUTINE mppsend_dp 73 # define RECVROUTINE mpprecv_dp 74 # define MPI_TYPE MPI_DOUBLE_PRECISION 75 # define HUGEVAL(x) HUGE(x/**/_dp) 76 # endif 77 78 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 49 79 !!---------------------------------------------------------------------- 50 80 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 51 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 52 82 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 83 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 84 REAL(wp) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 53 85 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 54 86 ! 87 LOGICAL :: ll_add_line 55 88 INTEGER :: ji, jj, jk, jl, jh, jf, jr ! dummy loop indices 56 INTEGER :: ipi, ipj, ip k, ipl, ipf! dimension of the input array89 INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array 57 90 INTEGER :: imigr, iihom, ijhom ! local integers 58 INTEGER :: ierr, ibuffsize, ilci, ildi, ilei, iilb 59 INTEGER :: ij, iproc 91 INTEGER :: ierr, ibuffsize, iis0, iie0, impp 92 INTEGER :: ii1, ii2, ij1, ij2 93 INTEGER :: ipimax, i0max 94 INTEGER :: ij, iproc, ipni, ijnr 60 95 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 61 96 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 62 97 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather 63 98 ! ! Workspace for message transfers avoiding mpi_allgather 64 INTEGER :: ip f_j! sum of lines for all multi fields65 INTEGER :: js ! counter66 INTEGER , DIMENSION(:,:),ALLOCATABLE :: jj_s ! position of sent lines67 INTEGER , DIMENSION(:), ALLOCATABLE :: ipj_s ! number of sentlines68 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl69 REAL( wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabr70 REAL( wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk71 REAL( wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio99 INTEGER :: ipj_b ! sum of lines for all multi fields 100 INTEGER :: i012 ! 0, 1 or 2 101 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_s ! position of sent lines 102 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_b ! position of buffer lines 103 INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines 104 REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays 105 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztabglo, znorthloc 106 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo 72 107 !!---------------------------------------------------------------------- 73 108 ! … … 76 111 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 77 112 ! 78 IF( l_north_nogather ) THEN !== ????==!113 IF( l_north_nogather ) THEN !== no allgather exchanges ==! 79 114 80 ALLOCATE(ipj_s(ipf)) 81 82 ipj = 2 ! Max 2nd dimension of message transfers (last two j-line only) 83 ipj_s(:) = 1 ! Real 2nd dimension of message transfers (depending on perf requirement) 84 ! by default, only one line is exchanged 85 86 ALLOCATE( jj_s(ipf,2) ) 87 88 ! re-define number of exchanged lines : 89 ! must be two during the first two time steps 90 ! to correct possible incoherent values on North fold lines from restart 91 115 ! --- define number of exchanged lines --- 116 ! 117 ! In theory we should exchange only nn_hls lines. 118 ! 119 ! However, some other points are duplicated in the north pole folding: 120 ! - jperio=[34], grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) 121 ! - jperio=[34], grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 122 ! - jperio=[34], grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) 123 ! - jperio=[34], grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) 124 ! - jperio=[56], grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) 125 ! - jperio=[56], grid=U : no points are duplicated 126 ! - jperio=[56], grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 127 ! - jperio=[56], grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) 128 ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) 129 ! This explain why these duplicated points may have different values even if they are at the exact same location. 130 ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. 131 ! This is slightly slower but necessary to avoid different values on identical grid points!! 132 ! 92 133 !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!! 93 134 !!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!! 94 135 !!!!!!!!! I don't know why we must do that... !!!!!!!! 95 136 l_full_nf_update = .TRUE. 96 97 ipj_s(:) = 2 137 ! also force it if not restart during the first 2 steps (leap frog?) 138 ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) 139 140 ALLOCATE(ipj_s(ipf)) ! how many lines do we exchange? 141 IF( ll_add_line ) THEN 142 DO jf = 1, ipf ! Loop over the number of arrays to be processed 143 ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4 .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) ) 144 END DO 145 ELSE 146 ipj_s(:) = nn_hls 147 ENDIF 148 149 ipj = MAXVAL(ipj_s(:)) ! Max 2nd dimension of message transfers 150 ipj_b = SUM( ipj_s(:)) ! Total number of lines to be exchanged 151 ALLOCATE( jj_s(ipj, ipf), jj_b(ipj, ipf) ) 98 152 99 153 ! Index of modifying lines in input 154 ij1 = 0 100 155 DO jf = 1, ipf ! Loop over the number of arrays to be processed 101 156 ! 102 157 SELECT CASE ( npolj ) 103 !104 158 CASE ( 3, 4 ) ! * North fold T-point pivot 105 !106 159 SELECT CASE ( NAT_IN(jf) ) 107 ! 108 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 109 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 110 CASE ( 'V' , 'F' ) ! V-, F-point 111 jj_s(jf,1) = nlcj - 3 ; jj_s(jf,2) = nlcj - 2 160 CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point 161 CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point 112 162 END SELECT 113 ! 114 CASE ( 5, 6 ) ! * North fold F-point pivot 163 CASE ( 5, 6 ) ! * North fold F-point pivot 115 164 SELECT CASE ( NAT_IN(jf) ) 116 ! 117 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 118 jj_s(jf,1) = nlcj - 1 119 ipj_s(jf) = 1 ! need only one line anyway 120 CASE ( 'V' , 'F' ) ! V-, F-point 121 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 165 CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point 166 CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point 122 167 END SELECT 123 !124 168 END SELECT 125 ! 126 ENDDO 127 ! 128 ipf_j = sum (ipj_s(:)) ! Total number of lines to be exchanged 129 ! 130 ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 131 ! 132 js = 0 133 DO jf = 1, ipf ! Loop over the number of arrays to be processed 169 ! 134 170 DO jj = 1, ipj_s(jf) 135 js = js + 1 136 DO jl = 1, ipl 137 DO jk = 1, ipk 138 znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) 171 ij1 = ij1 + 1 172 jj_b(jj,jf) = ij1 173 jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012 174 END DO 175 ! 176 END DO 177 ! 178 ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) ) ! store all the data to be sent in a buffer array 179 ibuffsize = jpimax * ipj_b * ipk * ipl 180 ! 181 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 182 DO jj = 1, ipj_s(jf) 183 ij1 = jj_b(jj,jf) 184 ij2 = jj_s(jj,jf) 185 DO ji = 1, jpi 186 ztabb(ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 187 END DO 188 DO ji = jpi+1, jpimax 189 ztabb(ji,ij1,jk,jl) = HUGEVAL(0.) ! avoid sending uninitialized values (make sure we don't use it) 190 END DO 191 END DO 192 END DO ; END DO ; END DO 193 ! 194 ! start waiting time measurement 195 IF( ln_timing ) CALL tic_tac(.TRUE.) 196 ! 197 ! send the data as soon as possible 198 DO jr = 1, nsndto 199 iproc = nfproc(isendto(jr)) 200 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 201 CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 202 ENDIF 203 END DO 204 ! 205 ipimax = jpimax * jpmaxngh 206 ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax,ipj_b,ipk,ipl) ) 207 ! 208 DO jr = 1, nsndto 209 ! 210 ipni = isendto(jr) 211 iproc = nfproc(ipni) 212 ipi = nfjpi (ipni) 213 ! 214 IF( ipni == 1 ) THEN ; iis0 = 1 ! domain left side: as e-w comm already done -> from 1st column 215 ELSE ; iis0 = 1 + nn_hls ! default: -> from inner domain 216 ENDIF 217 IF( ipni == jpni ) THEN ; iie0 = ipi ! domain right side: as e-w comm already done -> until last column 218 ELSE ; iie0 = ipi - nn_hls ! default: -> until inner domain 219 ENDIF 220 impp = nfimpp(ipni) - nfimpp(isendto(1)) 221 ! 222 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 223 ! 224 SELECT CASE ( kfillmode ) 225 CASE ( jpfillnothing ) ! no filling 226 CASE ( jpfillcopy ) ! filling with inner domain values 227 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 228 DO jj = 1, ipj_s(jf) 229 ij1 = jj_b(jj,jf) 230 ij2 = jj_s(jj,jf) 231 DO ji = iis0, iie0 232 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point 233 END DO 234 END DO 235 END DO ; END DO ; END DO 236 CASE ( jpfillcst ) ! filling with constant value 237 DO jl = 1, ipl ; DO jk = 1, ipk 238 DO jj = 1, ipj_b 239 DO ji = iis0, iie0 240 ztabr(impp+ji,jj,jk,jl) = pfillval 241 END DO 242 END DO 243 END DO ; END DO 244 END SELECT 245 ! 246 ELSE IF( iproc == narea-1 ) THEN ! get data from myself! 247 ! 248 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 249 DO jj = 1, ipj_s(jf) 250 ij1 = jj_b(jj,jf) 251 ij2 = jj_s(jj,jf) 252 DO ji = iis0, iie0 253 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 254 END DO 139 255 END DO 256 END DO ; END DO ; END DO 257 ! 258 ELSE ! get data from a neighbour trough communication 259 ! 260 CALL RECVROUTINE(5, ztabw, ibuffsize, iproc) 261 DO jl = 1, ipl ; DO jk = 1, ipk 262 DO jj = 1, ipj_b 263 DO ji = iis0, iie0 264 ztabr(impp+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl) 265 END DO 266 END DO 267 END DO ; END DO 268 269 ENDIF 270 ! 271 END DO ! nsndto 272 ! 273 IF( ln_timing ) CALL tic_tac(.FALSE.) 274 ! 275 ! North fold boundary condition 276 ! 277 DO jf = 1, ipf 278 ij1 = jj_b( 1 ,jf) 279 ij2 = jj_b(ipj_s(jf),jf) 280 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ij1:ij2,:,:), cd_nat LBC_ARG, psgn LBC_ARG ) 281 END DO 282 ! 283 DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s ) 284 ! 285 DO jr = 1,nsndto 286 iproc = nfproc(isendto(jr)) 287 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 288 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) ! put the wait at the very end just before the deallocate 289 ENDIF 290 END DO 291 DEALLOCATE( ztabb ) 292 ! 293 ELSE !== allgather exchanges ==! 294 ! 295 ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) 296 ipj = nn_hls + 2 297 ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) 298 ipj2 = 2 * nn_hls + 2 299 ! 300 i0max = jpimax - 2 * nn_hls 301 ibuffsize = i0max * ipj * ipk * ipl * ipf 302 ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) 303 ! 304 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab 305 DO jj = 1, ipj 306 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 307 DO ji = 1, Ni_0 308 ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 309 znorthloc(ji,jj,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) 310 END DO 311 DO ji = Ni_0+1, i0max 312 znorthloc(ji,jj,jk,jl,jf) = HUGEVAL(0.) ! avoid sending uninitialized values (make sure we don't use it) 140 313 END DO 141 314 END DO 142 END DO 143 ! 144 ibuffsize = jpimax * ipf_j * ipk * ipl 145 ! 146 ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) 147 ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) ) 148 ! when some processors of the north fold are suppressed, 149 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 150 ! and we need a default definition to 0. 151 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 152 IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp 153 ! 154 DO jr = 1, nsndto 155 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 156 CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 157 ENDIF 158 END DO 159 ! 160 DO jr = 1,nsndto 161 iproc = nfipproc(isendto(jr),jpnj) 162 IF(iproc /= -1) THEN 163 iilb = nimppt(iproc+1) 164 ilci = nlcit (iproc+1) 165 ildi = nldit (iproc+1) 166 ilei = nleit (iproc+1) 167 IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column 168 IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column 169 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 170 ENDIF 171 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 172 CALL mpprecv(5, zfoldwk, ibuffsize, iproc) 173 js = 0 174 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 175 js = js + 1 176 DO jl = 1, ipl 177 DO jk = 1, ipk 178 DO ji = ildi, ilei 179 ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) 315 END DO ; END DO ; END DO 316 ! 317 ! start waiting time measurement 318 IF( ln_timing ) CALL tic_tac(.TRUE.) 319 CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 320 ! stop waiting time measurement 321 IF( ln_timing ) CALL tic_tac(.FALSE.) 322 DEALLOCATE( znorthloc ) 323 ALLOCATE( ztabglo(jpiglo,ipj2,ipk,ipl,ipf) ) 324 ! 325 ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines 326 ijnr = 0 327 DO jr = 1, jpni ! recover the global north array 328 iproc = nfproc(jr) 329 impp = nfimpp(jr) 330 ipi = nfjpi( jr) - 2 * nn_hls ! corresponds to Ni_0 but for subdomain iproc 331 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 332 ! 333 SELECT CASE ( kfillmode ) 334 CASE ( jpfillnothing ) ! no filling 335 CASE ( jpfillcopy ) ! filling with inner domain values 336 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 337 DO jj = 1, ipj 338 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 339 DO ji = 1, ipi 340 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 341 ztabglo(ii1,jj,jk,jl,jf) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point 180 342 END DO 181 343 END DO 344 END DO ; END DO ; END DO 345 CASE ( jpfillcst ) ! filling with constant value 346 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 347 DO jj = 1, ipj 348 DO ji = 1, ipi 349 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 350 ztabglo(ii1,jj,jk,jl,jf) = pfillval 351 END DO 352 END DO 353 END DO ; END DO ; END DO 354 END SELECT 355 ! 356 ELSE 357 ijnr = ijnr + 1 358 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 359 DO jj = 1, ipj 360 DO ji = 1, ipi 361 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 362 ztabglo(ii1,jj,jk,jl,jf) = znorthglo(ji,jj,jk,jl,jf,ijnr) 363 END DO 182 364 END DO 183 END DO; END DO 184 ELSE IF( iproc == narea-1 ) THEN 185 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 186 DO jl = 1, ipl 187 DO jk = 1, ipk 188 DO ji = ildi, ilei 189 ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) 190 END DO 191 END DO 192 END DO 193 END DO; END DO 194 ENDIF 195 END DO 196 IF( l_isend ) THEN 197 DO jr = 1,nsndto 198 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 199 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 200 ENDIF 365 END DO ; END DO ; END DO 366 ENDIF 367 ! 368 END DO ! jpni 369 DEALLOCATE( znorthglo ) 370 ! 371 DO jf = 1, ipf 372 CALL lbc_nfd( ztabglo(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 373 DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity 374 DO jj = 1, nn_hls + 1 375 ij1 = ipj2 - (nn_hls + 1) + jj ! need only the last nn_hls + 1 lines until ipj2 376 ztabglo( 1:nn_hls,ij1,jk,jl,jf) = ztabglo(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl,jf) 377 ztabglo(jpiglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo( nn_hls+1: 2*nn_hls,ij1,jk,jl,jf) 378 END DO 379 END DO ; END DO 380 END DO 381 ! 382 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN 383 DO jj = 1, nn_hls + 1 384 ij1 = jpj - (nn_hls + 1) + jj ! last nn_hls + 1 lines until jpj 385 ij2 = ipj2 - (nn_hls + 1) + jj ! last nn_hls + 1 lines until ipj2 386 DO ji= 1, jpi 387 ii2 = mig(ji) 388 ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(ii2,ij2,jk,jl,jf) 389 END DO 201 390 END DO 202 ENDIF 203 ! 204 ! North fold boundary condition 205 ! 206 DO jf = 1, ipf 207 CALL lbc_nfd_nogather(ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 208 END DO 209 ! 210 DEALLOCATE( zfoldwk ) 211 DEALLOCATE( ztabr ) 212 DEALLOCATE( jj_s ) 213 DEALLOCATE( ipj_s ) 214 ELSE !== ???? ==! 215 ! 216 ipj = 4 ! 2nd dimension of message transfers (last j-lines) 217 ! 218 ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) ) 219 ! 220 DO jf = 1, ipf ! put in znorthloc the last ipj j-lines of ptab 221 DO jl = 1, ipl 222 DO jk = 1, ipk 223 DO jj = nlcj - ipj +1, nlcj 224 ij = jj - nlcj + ipj 225 znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 226 END DO 227 END DO 228 END DO 229 END DO 230 ! 231 ibuffsize = jpimax * ipj * ipk * ipl * ipf 232 ! 233 ALLOCATE( ztab (jpiglo,ipj,ipk,ipl,ipf ) ) 234 ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) ) 235 ! 236 ! when some processors of the north fold are suppressed, 237 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 238 ! and we need a default definition to 0. 239 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 240 IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp 241 ! 242 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_DOUBLE_PRECISION, & 243 & znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 244 ! 245 ! 246 DO jr = 1, ndim_rank_north ! recover the global north array 247 iproc = nrank_north(jr) + 1 248 iilb = nimppt(iproc) 249 ilci = nlcit (iproc) 250 ildi = nldit (iproc) 251 ilei = nleit (iproc) 252 IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column 253 IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column 254 DO jf = 1, ipf 255 DO jl = 1, ipl 256 DO jk = 1, ipk 257 DO jj = 1, ipj 258 DO ji = ildi, ilei 259 ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr) 260 END DO 261 END DO 262 END DO 263 END DO 264 END DO 265 END DO 266 DO jf = 1, ipf 267 CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 268 END DO 269 ! 270 DO jf = 1, ipf 271 DO jl = 1, ipl 272 DO jk = 1, ipk 273 DO jj = nlcj-ipj+1, nlcj ! Scatter back to ARRAY_IN 274 ij = jj - nlcj + ipj 275 DO ji= 1, nlci 276 ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf) 277 END DO 278 END DO 279 END DO 280 END DO 281 END DO 282 ! 283 ! 284 DEALLOCATE( ztab ) 285 DEALLOCATE( znorthgloio ) 286 ENDIF 287 ! 288 DEALLOCATE( znorthloc ) 391 END DO ; END DO ; END DO 392 ! 393 DEALLOCATE( ztabglo ) 394 ! 395 ENDIF ! l_north_nogather 289 396 ! 290 397 END SUBROUTINE ROUTINE_NFD 291 398 399 #undef PRECISION 400 #undef MPI_TYPE 401 #undef SENDROUTINE 402 #undef RECVROUTINE 292 403 #undef ARRAY_TYPE 293 404 #undef NAT_IN … … 298 409 #undef F_SIZE 299 410 #undef LBC_ARG 411 #undef HUGEVAL -
utils/tools/DOMAINcfg/src/mppini.F90
r13204 r14623 8 8 !! 8.0 ! 1998-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions 9 9 !! NEMO 1.0 ! 2004-01 (G. Madec, J.M Molines) F90 : free form , north fold jpni > 1 10 !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add mpp_init_nfdcom11 !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) mpp_init_nfdcom: setup avoiding MPI communication10 !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add init_nfdcom 11 !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) init_nfdcom: setup avoiding MPI communication 12 12 !! 4.0 ! 2016-06 (G. Madec) use domain configuration file instead of bathymetry file 13 13 !! 4.0 ! 2017-06 (J.M. Molines, T. Lovato) merge of mppini and mppini_2 … … 15 15 16 16 !!---------------------------------------------------------------------- 17 !! mpp_init : Lay out the global domain over processors with/without land processor elimination 18 !! mpp_init_mask : Read global bathymetric information to facilitate land suppression 19 !! mpp_init_partition: Calculate MPP domain decomposition 20 !! factorise : Calculate the factors of the no. of MPI processes 21 !! mpp_init_nfdcom : Setup for north fold exchanges with explicit point-to-point messaging 17 !! mpp_init : Lay out the global domain over processors with/without land processor elimination 18 !! init_ioipsl: IOIPSL initialization in mpp 19 !! init_nfdcom: Setup for north fold exchanges with explicit point-to-point messaging 20 !! init_doloop: set the starting/ending indices of DO-loop used in do_loop_substitute 22 21 !!---------------------------------------------------------------------- 23 22 USE dom_oce ! ocean space and time domain 23 ! USE bdy_oce ! open BounDarY 24 24 ! 25 USE lbcnfd , ONLY : isendto, nsndto , nfsloop, nfeloop! Setup of north fold exchanges25 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 26 26 USE lib_mpp ! distribued memory computing library 27 27 USE iom ! nemo I/O library … … 32 32 PRIVATE 33 33 34 PUBLIC mpp_init ! called by opa.F90 35 36 INTEGER :: numbot = -1 ! 'bottom_level' local logical unit 34 PUBLIC mpp_init ! called by nemogcm.F90 35 PUBLIC mpp_getnum ! called by prtctl 36 PUBLIC mpp_basesplit ! called by prtctl 37 PUBLIC mpp_is_ocean ! called by prtctl 38 39 INTEGER :: numbot = -1 ! 'bottom_level' local logical unit 40 INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit 37 41 38 42 !!---------------------------------------------------------------------- 39 43 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 40 !! $Id: mppini.F90 1 0570 2019-01-24 15:14:49Z acc $44 !! $Id: mppini.F90 13305 2020-07-14 17:12:25Z acc $ 41 45 !! Software governed by the CeCILL license (see ./LICENSE) 42 46 !!---------------------------------------------------------------------- … … 58 62 !!---------------------------------------------------------------------- 59 63 ! 64 jpiglo = Ni0glo 65 jpjglo = Nj0glo 60 66 jpimax = jpiglo 61 67 jpjmax = jpjglo … … 63 69 jpj = jpjglo 64 70 jpk = jpkglo 65 jpim1 = jpi-1 ! inner domain indices 66 jpjm1 = jpj-1 ! " " 67 jpkm1 = MAX( 1, jpk-1 ) ! " " 71 jpim1 = jpi-1 ! inner domain indices 72 jpjm1 = jpj-1 ! " " 73 jpkm1 = MAX( 1, jpk-1 ) ! " " 74 ! 75 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) 76 ! 68 77 jpij = jpi*jpj 69 78 jpni = 1 70 79 jpnj = 1 71 80 jpnij = jpni*jpnj 72 nimpp = 1 ! 81 nn_hls = 1 82 nimpp = 1 73 83 njmpp = 1 74 nlci = jpi75 nlcj = jpj76 nldi = 177 nldj = 178 nlei = jpi79 nlej = jpj80 84 nbondi = 2 81 85 nbondj = 2 82 npolj = jperio 86 nidom = FLIO_DOM_NONE 87 npolj = 0 88 IF( jperio == 3 .OR. jperio == 4 ) npolj = 3 89 IF( jperio == 5 .OR. jperio == 6 ) npolj = 5 83 90 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 84 91 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) … … 95 102 CALL ctl_stop( 'mpp_init: equality jpni = jpnj = jpnij = 1 is not satisfied', & 96 103 & 'the domain is lay out for distributed memory computing!' ) 97 104 ! 98 105 #if defined key_agrif 99 IF (.not.agrif_root()) THEN 100 CALL agrif_nemo_init 101 ENDIF 106 CALL agrif_nemo_init() 102 107 103 108 IF( .NOT. Agrif_Root() ) THEN ! AGRIF children: specific setting (cf. agrif_user.F90) 104 109 print *,'nbcellsx = ',nbcellsx,nbghostcells_x 105 110 print *,'nbcellsy = ',nbcellsy,nbghostcells_y_s,nbghostcells_y_n 106 IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells_x ) THEN111 IF( Ni0glo /= nbcellsx + 2 + 2*nbghostcells_x ) THEN 107 112 IF(lwp) THEN 108 113 WRITE(numout,*) 109 WRITE(numout,*) ' jpiglo should be: ', nbcellsx + 2 + 2*nbghostcells_x114 WRITE(numout,*) 'Ni0glo should be: ', nbcellsx + 2 + 2*nbghostcells_x 110 115 ENDIF 111 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nbghostcells_x' )116 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires Ni0glo == nbcellsx + 2 + 2*nbghostcells_x' ) 112 117 ENDIF 113 IF( jpjglo /= nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n ) THEN118 IF( Nj0glo /= nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n ) THEN 114 119 IF(lwp) THEN 115 120 WRITE(numout,*) 116 WRITE(numout,*) ' jpjglo shoud be: ', nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n121 WRITE(numout,*) 'Nj0glo shoud be: ', nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n 117 122 ENDIF 118 123 CALL ctl_stop( 'STOP', & 119 'mpp_init: Agrif children requires jpjglo == nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n' )124 'mpp_init: Agrif children requires Nj0glo == nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n' ) 120 125 ENDIF 121 126 IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'mpp_init:Agrif children requires ln_use_jattr = .false. ' ) 122 127 ENDIF 123 128 #endif 124 !125 129 END SUBROUTINE mpp_init 126 130 … … 151 155 !! njmpp : latitudinal index 152 156 !! narea : number for local area 153 !! nlci : first dimension154 !! nlcj : second dimension155 157 !! nbondi : mark for "east-west local boundary" 156 158 !! nbondj : mark for "north-south local boundary" … … 163 165 INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices 164 166 INTEGER :: inijmin 165 INTEGER :: i2add166 167 INTEGER :: inum ! local logical unit 167 INTEGER :: idir, ifreq , icont! local integers168 INTEGER :: idir, ifreq ! local integers 168 169 INTEGER :: ii, il1, ili, imil ! - - 169 170 INTEGER :: ij, il2, ilj, ijm1 ! - - … … 173 174 INTEGER :: ierr, ios ! 174 175 INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 175 LOGICAL :: llbest 176 LOGICAL :: llbest, llauto 176 177 LOGICAL :: llwrtlay 178 LOGICAL :: ln_listonly 177 179 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 178 180 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - 179 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, i lci, ibondi, ipproc ! 2D workspace180 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, i lcj, ibondj, ipolj ! - -181 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: i lei, ildi, iono, ioea ! - -182 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: i lej, ildj, ioso, iowe ! - -181 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi, ibondi, ipproc ! 2D workspace 182 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj, ibondj, ipolj ! - - 183 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iie0, iis0, iono, ioea ! - - 184 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ije0, ijs0, ioso, iowe ! - - 183 185 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - 184 !!---------------------------------------------------------------------- 185 186 llwrtlay = lwp 186 ! NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & 187 ! & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & 188 ! & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & 189 ! & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 190 ! & cn_ice, nn_ice_dta, & 191 ! & ln_vol, nn_volctl, nn_rimwidth 192 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 193 !!---------------------------------------------------------------------- 194 ! 195 llwrtlay = lwm .OR. sn_cfctl%l_layout 196 ! 197 ! 0. read namelists parameters 198 ! ----------------------------------- 199 ! 200 READ ( numnam_ref, nammpp, IOSTAT = ios, ERR = 901 ) 201 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist' ) 202 READ ( numnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 203 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) 204 ! 205 nn_hls = MAX(1, nn_hls) ! nn_hls must be > 0 206 IF(lwp) THEN 207 WRITE(numout,*) ' Namelist nammpp' 208 IF( jpni < 1 .OR. jpnj < 1 ) THEN 209 WRITE(numout,*) ' jpni and jpnj will be calculated automatically' 210 ELSE 211 WRITE(numout,*) ' processor grid extent in i jpni = ', jpni 212 WRITE(numout,*) ' processor grid extent in j jpnj = ', jpnj 213 ENDIF 214 WRITE(numout,*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather 215 WRITE(numout,*) ' halo width (applies to both rows and columns) nn_hls = ', nn_hls 216 ENDIF 217 ! 218 IF(lwm) WRITE( numond, nammpp ) 219 ! 220 !!!------------------------------------ 221 !!! nn_hls shloud be read in nammpp 222 !!!------------------------------------ 223 jpiglo = Ni0glo + 2 * nn_hls 224 jpjglo = Nj0glo + 2 * nn_hls 225 ! 226 ! do we need to take into account bdy_msk? 227 ! READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 228 !903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' ) 229 ! READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 230 !904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' ) 187 231 ! 188 232 IF( ln_read_cfg ) CALL iom_open( cn_domcfg, numbot ) 233 ! IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) 234 ! 235 IF( ln_listonly ) CALL bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core 189 236 ! 190 237 ! 1. Dimension arrays for subdomains 191 238 ! ----------------------------------- 192 239 ! 193 ! If dimensions of processor grid weren't specified in the namelist file240 ! If dimensions of processors grid weren't specified in the namelist file 194 241 ! then we calculate them here now that we have our communicator size 242 IF(lwp) THEN 243 WRITE(numout,*) 'mpp_init:' 244 WRITE(numout,*) '~~~~~~~~ ' 245 WRITE(numout,*) 246 ENDIF 195 247 IF( jpni < 1 .OR. jpnj < 1 ) THEN 196 CALL mpp_init_bestpartition( mppsize, jpni, jpnj ) 248 CALL bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes 249 llauto = .TRUE. 197 250 llbest = .TRUE. 198 251 ELSE 199 CALL mpp_init_bestpartition( mppsize, inbi, inbj, icnt2 ) 200 CALL mpp_basic_decomposition( jpni, jpnj, jpimax, jpjmax ) 201 CALL mpp_basic_decomposition( inbi, inbj, iimax, ijmax ) 202 IF( iimax*ijmax < jpimax*jpjmax ) THEN 252 llauto = .FALSE. 253 CALL bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes 254 ! largest subdomain size for mpi decoposition jpni*jpnj given in the namelist 255 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax ) 256 ! largest subdomain size for mpi decoposition inbi*inbj given by bestpartition 257 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, inbi, inbj, iimax, ijmax ) 258 icnt1 = jpni*jpnj - mppsize ! number of land subdomains that should be removed to use mppsize mpi processes 259 IF(lwp) THEN 260 WRITE(numout,9000) ' The chosen domain decomposition ', jpni, ' x ', jpnj, ' with ', icnt1, ' land subdomains' 261 WRITE(numout,9002) ' - uses a total of ', mppsize,' mpi process' 262 WRITE(numout,9000) ' - has mpi subdomains with a maximum size of (jpi = ', jpimax, ', jpj = ', jpjmax, & 263 & ', jpi*jpj = ', jpimax*jpjmax, ')' 264 WRITE(numout,9000) ' The best domain decompostion ', inbi, ' x ', inbj, ' with ', icnt2, ' land subdomains' 265 WRITE(numout,9002) ' - uses a total of ', inbi*inbj-icnt2,' mpi process' 266 WRITE(numout,9000) ' - has mpi subdomains with a maximum size of (jpi = ', iimax, ', jpj = ', ijmax, & 267 & ', jpi*jpj = ', iimax* ijmax, ')' 268 ENDIF 269 IF( iimax*ijmax < jpimax*jpjmax ) THEN ! chosen subdomain size is larger that the best subdomain size 203 270 llbest = .FALSE. 204 icnt1 = jpni*jpnj - mppsize 205 WRITE(ctmp1,9000) ' The chosen domain decomposition ', jpni, ' x ', jpnj, ' with ', icnt1, ' land sub-domains' 206 WRITE(ctmp2,9000) ' has larger MPI subdomains (jpi = ', jpimax, ', jpj = ', jpjmax, ', jpi*jpj = ', jpimax*jpjmax, ')' 207 WRITE(ctmp3,9000) ' than the following domain decompostion ', inbi, ' x ', inbj, ' with ', icnt2, ' land sub-domains' 208 WRITE(ctmp4,9000) ' which MPI subdomains size is jpi = ', iimax, ', jpj = ', ijmax, ', jpi*jpj = ', iimax*ijmax, ' ' 209 CALL ctl_warn( 'mpp_init:', '~~~~~~~~ ', ctmp1, ctmp2, ctmp3, ctmp4, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) 271 IF ( inbi*inbj-icnt2 < mppsize ) THEN 272 WRITE(ctmp1,*) ' ==> You could therefore have smaller mpi subdomains with less mpi processes' 273 ELSE 274 WRITE(ctmp1,*) ' ==> You could therefore have smaller mpi subdomains with the same number of mpi processes' 275 ENDIF 276 CALL ctl_warn( ' ', ctmp1, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) 277 ELSE IF ( iimax*ijmax == jpimax*jpjmax .AND. (inbi*inbj-icnt2) < mppsize) THEN 278 llbest = .FALSE. 279 WRITE(ctmp1,*) ' ==> You could therefore have the same mpi subdomains size with less mpi processes' 280 CALL ctl_warn( ' ', ctmp1, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) 210 281 ELSE 211 282 llbest = .TRUE. … … 215 286 ! look for land mpi subdomains... 216 287 ALLOCATE( llisoce(jpni,jpnj) ) 217 CALL mpp_i nit_isoce( jpni, jpnj,llisoce )288 CALL mpp_is_ocean( llisoce ) 218 289 inijmin = COUNT( llisoce ) ! number of oce subdomains 219 290 220 IF( mppsize < inijmin ) THEN 291 IF( mppsize < inijmin ) THEN ! too many oce subdomains: can happen only if jpni and jpnj are prescribed... 221 292 WRITE(ctmp1,9001) ' With this specified domain decomposition: jpni = ', jpni, ' jpnj = ', jpnj 222 293 WRITE(ctmp2,9002) ' we can eliminate only ', jpni*jpnj - inijmin, ' land mpi subdomains therefore ' 223 294 WRITE(ctmp3,9001) ' the number of ocean mpi subdomains (', inijmin,') exceed the number of MPI processes:', mppsize 224 295 WRITE(ctmp4,*) ' ==>>> There is the list of best domain decompositions you should use: ' 225 CALL ctl_stop( 'mpp_init:', '~~~~~~~~ ', ctmp1, ctmp2, ctmp3, ctmp4 ) 226 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 227 CALL ctl_stop( 'STOP' ) 228 ENDIF 229 230 IF( mppsize > jpni*jpnj ) THEN 231 WRITE(ctmp1,9003) ' The number of mpi processes: ', mppsize 232 WRITE(ctmp2,9003) ' exceeds the maximum number of subdomains (ocean+land) = ', jpni*jpnj 233 WRITE(ctmp3,9001) ' defined by the following domain decomposition: jpni = ', jpni, ' jpnj = ', jpnj 234 WRITE(ctmp4,*) ' ==>>> There is the list of best domain decompositions you should use: ' 235 CALL ctl_stop( 'mpp_init:', '~~~~~~~~ ', ctmp1, ctmp2, ctmp3, ctmp4 ) 236 CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 237 CALL ctl_stop( 'STOP' ) 296 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) 297 CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 298 ENDIF 299 300 IF( mppsize > jpni*jpnj ) THEN ! not enough mpi subdomains for the total number of mpi processes 301 IF(lwp) THEN 302 WRITE(numout,9003) ' The number of mpi processes: ', mppsize 303 WRITE(numout,9003) ' exceeds the maximum number of subdomains (ocean+land) = ', jpni*jpnj 304 WRITE(numout,9001) ' defined by the following domain decomposition: jpni = ', jpni, ' jpnj = ', jpnj 305 WRITE(numout, *) ' You should: ' 306 IF( llauto ) THEN 307 WRITE(numout,*) ' - either prescribe your domain decomposition with the namelist variables' 308 WRITE(numout,*) ' jpni and jpnj to match the number of mpi process you want to use, ' 309 WRITE(numout,*) ' even IF it not the best choice...' 310 WRITE(numout,*) ' - or keep the automatic and optimal domain decomposition by picking up one' 311 WRITE(numout,*) ' of the number of mpi process proposed in the list bellow' 312 ELSE 313 WRITE(numout,*) ' - either properly prescribe your domain decomposition with jpni and jpnj' 314 WRITE(numout,*) ' in order to be consistent with the number of mpi process you want to use' 315 WRITE(numout,*) ' even IF it not the best choice...' 316 WRITE(numout,*) ' - or use the automatic and optimal domain decomposition and pick up one of' 317 WRITE(numout,*) ' the domain decomposition proposed in the list bellow' 318 ENDIF 319 WRITE(numout,*) 320 ENDIF 321 CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core 238 322 ENDIF 239 323 … … 244 328 WRITE(ctmp3,9002) ' we suppressed ', jpni*jpnj - mppsize, ' land subdomains ' 245 329 WRITE(ctmp4,9002) ' BUT we had to keep ', mppsize - inijmin, ' land subdomains that are useless...' 246 CALL ctl_warn( 'mpp_init:', '~~~~~~~~ ',ctmp1, ctmp2, ctmp3, ctmp4, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' )330 CALL ctl_warn( ctmp1, ctmp2, ctmp3, ctmp4, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) 247 331 ELSE ! mppsize = inijmin 248 332 IF(lwp) THEN 249 IF(llbest) WRITE(numout,*) ' mpp_init: You use an optimal domaindecomposition'250 WRITE(numout,*) '~~~~~~~~ '333 IF(llbest) WRITE(numout,*) ' ==> you use the best mpi decomposition' 334 WRITE(numout,*) 251 335 WRITE(numout,9003) ' Number of mpi processes: ', mppsize 252 336 WRITE(numout,9003) ' Number of ocean subdomains = ', inijmin … … 260 344 9003 FORMAT (a, i5) 261 345 262 IF( numbot /= -1 ) CALL iom_close( numbot ) 263 264 ALLOCATE( nfiimpp(jpni,jpnj), nfipproc(jpni,jpnj), nfilcit(jpni,jpnj) , & 265 & nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) , & 266 & njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) , & 267 & nleit(jpnij) , nlejt(jpnij) , & 346 ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , & 347 & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , & 348 & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , & 349 & nie0all(jpnij) , nje0all(jpnij) , & 268 350 & iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), & 269 351 & ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), & 270 & iimppt(jpni,jpnj), i lci(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), &271 & ijmppt(jpni,jpnj), i lcj(jpni,jpnj), ibondj(jpni,jpnj),ipolj(jpni,jpnj), &272 & ilei(jpni,jpnj), ildi(jpni,jpnj), iono(jpni,jpnj),ioea(jpni,jpnj), &273 & ilej(jpni,jpnj), ildj(jpni,jpnj), ioso(jpni,jpnj),iowe(jpni,jpnj), &352 & iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), & 353 & ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), & 354 & iie0(jpni,jpnj), iis0(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), & 355 & ije0(jpni,jpnj), ijs0(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), & 274 356 & STAT=ierr ) 275 357 CALL mpp_sum( 'mppini', ierr ) … … 277 359 278 360 #if defined key_agrif 361 CALL agrif_nemo_init() 279 362 IF( .NOT. Agrif_Root() ) THEN ! AGRIF children: specific setting (cf. agrif_user.F90) 280 CALL agrif_nemo_init 281 IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells_x ) THEN 363 IF( Ni0glo /= nbcellsx + 2 + 2*nbghostcells_x ) THEN 282 364 IF(lwp) THEN 283 365 WRITE(numout,*) 284 WRITE(numout,*) ' jpiglo should be: ', nbcellsx + 2 + 2*nbghostcells_x366 WRITE(numout,*) 'Ni0glo should be: ', nbcellsx + 2 + 2*nbghostcells_x 285 367 ENDIF 286 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nbghostcells' )368 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires Ni0glo == nbcellsx + 2 + 2*nbghostcells_x' ) 287 369 ENDIF 288 IF( jpjglo /= nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n ) THEN370 IF( Nj0glo /= nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n ) THEN 289 371 IF(lwp) THEN 290 372 WRITE(numout,*) 291 WRITE(numout,*) ' jpjglo shoud be: ', nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n373 WRITE(numout,*) 'Nj0glo shoud be: ', nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n 292 374 ENDIF 293 375 CALL ctl_stop( 'STOP', & 294 'mpp_init: Agrif children requires jpjglo == nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n' )376 'mpp_init: Agrif children requires Nj0glo == nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n' ) 295 377 ENDIF 296 378 IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'mpp_init:Agrif children requires ln_use_jattr = .false. ' ) … … 301 383 ! ----------------------------------- 302 384 ! 303 nreci = 2 * nn_hls 304 nrecj = 2 * nn_hls 305 CALL mpp_basic_decomposition( jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ilci, ilcj ) 306 nfiimpp(:,:) = iimppt(:,:) 307 nfilcit(:,:) = ilci(:,:) 385 386 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 387 CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 388 ! 389 !DO jn = 1, jpni 390 ! jproc = ipproc(jn,jpnj) 391 ! ii = iin(jproc+1) 392 ! ij = ijn(jproc+1) 393 ! nfproc(jn) = jproc 394 ! nfimpp(jn) = iimppt(ii,ij) 395 ! nfjpi (jn) = ijpi(ii,ij) 396 !END DO 397 nfproc(:) = ipproc(:,jpnj) 398 nfimpp(:) = iimppt(:,jpnj) 399 nfjpi (:) = ijpi(:,jpnj) 308 400 ! 309 401 IF(lwp) THEN … … 314 406 WRITE(numout,*) ' jpni = ', jpni 315 407 WRITE(numout,*) ' jpnj = ', jpnj 408 WRITE(numout,*) ' jpnij = ', jpnij 316 409 WRITE(numout,*) 317 WRITE(numout,*) ' sum i lci(i,1) = ', sum(ilci(:,1)), ' jpiglo = ', jpiglo318 WRITE(numout,*) ' sum i lcj(1,j) = ', sum(ilcj(1,:)), ' jpjglo = ', jpjglo410 WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 411 WRITE(numout,*) ' sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 319 412 ENDIF 320 413 … … 331 424 ii = 1 + MOD(iarea0,jpni) 332 425 ij = 1 + iarea0/jpni 333 ili = i lci(ii,ij)334 ilj = i lcj(ii,ij)426 ili = ijpi(ii,ij) 427 ilj = ijpj(ii,ij) 335 428 ibondi(ii,ij) = 0 ! default: has e-w neighbours 336 429 IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour … … 347 440 ioea(ii,ij) = iarea0 + 1 348 441 iono(ii,ij) = iarea0 + jpni 349 i ldi(ii,ij) = 1 + nn_hls350 i lei(ii,ij) = ili - nn_hls351 i ldj(ii,ij) = 1 + nn_hls352 i lej(ii,ij) = ilj - nn_hls442 iis0(ii,ij) = 1 + nn_hls 443 iie0(ii,ij) = ili - nn_hls 444 ijs0(ii,ij) = 1 + nn_hls 445 ije0(ii,ij) = ilj - nn_hls 353 446 354 447 ! East-West periodicity: change ibondi, ioea, iowe … … 388 481 ! ---------------------------- 389 482 ! 390 ! specify which subdomains are oce subdomains; other are land subdomains391 ipproc(:,:) = -1392 icont = -1393 DO jarea = 1, jpni*jpnj394 iarea0 = jarea - 1395 ii = 1 + MOD(iarea0,jpni)396 ij = 1 + iarea0/jpni397 IF( llisoce(ii,ij) ) THEN398 icont = icont + 1399 ipproc(ii,ij) = icont400 iin(icont+1) = ii401 ijn(icont+1) = ij402 ENDIF403 END DO404 ! if needed add some land subdomains to reach jpnij active subdomains405 i2add = jpnij - inijmin406 DO jarea = 1, jpni*jpnj407 iarea0 = jarea - 1408 ii = 1 + MOD(iarea0,jpni)409 ij = 1 + iarea0/jpni410 IF( .NOT. llisoce(ii,ij) .AND. i2add > 0 ) THEN411 icont = icont + 1412 ipproc(ii,ij) = icont413 iin(icont+1) = ii414 ijn(icont+1) = ij415 i2add = i2add - 1416 ENDIF417 END DO418 nfipproc(:,:) = ipproc(:,:)419 420 483 ! neighbour treatment: change ibondi, ibondj if next to a land zone 421 484 DO jarea = 1, jpni*jpnj … … 456 519 ENDIF 457 520 END DO 458 459 ! Update il[de][ij] according to modified ibond[ij]460 ! ----------------------461 DO jproc = 1, jpnij462 ii = iin(jproc)463 ij = ijn(jproc)464 IF( ibondi(ii,ij) == -1 .OR. ibondi(ii,ij) == 2 ) ildi(ii,ij) = 1465 IF( ibondi(ii,ij) == 1 .OR. ibondi(ii,ij) == 2 ) ilei(ii,ij) = ilci(ii,ij)466 IF( ibondj(ii,ij) == -1 .OR. ibondj(ii,ij) == 2 ) ildj(ii,ij) = 1467 IF( ibondj(ii,ij) == 1 .OR. ibondj(ii,ij) == 2 ) ilej(ii,ij) = ilcj(ii,ij)468 END DO469 521 470 522 ! 5. Subdomain print … … 479 531 DO jj = jpnj, 1, -1 480 532 WRITE(numout,9403) (' ',ji=il1,il2-1) 481 WRITE(numout,9402) jj, (i lci(ji,jj),ilcj(ji,jj),ji=il1,il2)533 WRITE(numout,9402) jj, (ijpi(ji,jj),ijpj(ji,jj),ji=il1,il2) 482 534 WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2) 483 535 WRITE(numout,9403) (' ',ji=il1,il2-1) … … 491 543 9401 FORMAT(' ' ,20(' ',i3,' ') ) 492 544 9402 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ') ) 493 9404 FORMAT(' * ' ,20(' ',i3,' * ') )545 9404 FORMAT(' * ' ,20(' ' ,i4,' * ') ) 494 546 ENDIF 495 547 … … 536 588 noea = ii_noea(narea) 537 589 nono = ii_nono(narea) 538 nlci = ilci(ii,ij)539 nldi = ildi(ii,ij)540 nlei = ilei(ii,ij)541 nlcj = ilcj(ii,ij)542 nldj = ildj(ii,ij)543 nlej = ilej(ii,ij)590 jpi = ijpi(ii,ij) 591 !!$ Nis0 = iis0(ii,ij) 592 !!$ Nie0 = iie0(ii,ij) 593 jpj = ijpj(ii,ij) 594 !!$ Njs0 = ijs0(ii,ij) 595 !!$ Nje0 = ije0(ii,ij) 544 596 nbondi = ibondi(ii,ij) 545 597 nbondj = ibondj(ii,ij) 546 598 nimpp = iimppt(ii,ij) 547 599 njmpp = ijmppt(ii,ij) 548 jpi = nlci 549 jpj = nlcj 550 jpk = jpkglo ! third dim 551 #if defined key_agrif 552 ! simple trick to use same vertical grid as parent but different number of levels: 553 ! Save maximum number of levels in jpkglo, then define all vertical grids with this number. 554 ! Suppress once vertical online interpolation is ok 555 !!$ IF(.NOT.Agrif_Root()) jpkglo = Agrif_Parent( jpkglo ) 556 #endif 557 jpim1 = jpi-1 ! inner domain indices 558 jpjm1 = jpj-1 ! " " 559 jpkm1 = MAX( 1, jpk-1 ) ! " " 560 jpij = jpi*jpj ! jpi x j 600 jpk = jpkglo ! third dim 601 ! 602 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 603 ! 604 jpim1 = jpi-1 ! inner domain indices 605 jpjm1 = jpj-1 ! " " 606 jpkm1 = MAX( 1, jpk-1 ) ! " " 607 jpij = jpi*jpj ! jpi x j 561 608 DO jproc = 1, jpnij 562 609 ii = iin(jproc) 563 610 ij = ijn(jproc) 564 nlcit(jproc) = ilci(ii,ij)565 n ldit(jproc) = ildi(ii,ij)566 n leit(jproc) = ilei(ii,ij)567 nlcjt(jproc) = ilcj(ii,ij)568 n ldjt(jproc) = ildj(ii,ij)569 n lejt(jproc) = ilej(ii,ij)611 jpiall (jproc) = ijpi(ii,ij) 612 nis0all(jproc) = iis0(ii,ij) 613 nie0all(jproc) = iie0(ii,ij) 614 jpjall (jproc) = ijpj(ii,ij) 615 njs0all(jproc) = ijs0(ii,ij) 616 nje0all(jproc) = ije0(ii,ij) 570 617 ibonit(jproc) = ibondi(ii,ij) 571 618 ibonjt(jproc) = ibondj(ii,ij) … … 581 628 WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 582 629 & ' ( local: ',narea,jpi,jpj,' )' 583 WRITE(inum,'(a)') 'nproc nlci nlcj nldi nldj nlei nlejnimp njmp nono noso nowe noea nbondi nbondj '630 WRITE(inum,'(a)') 'nproc jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 584 631 585 632 DO jproc = 1, jpnij 586 WRITE(inum,'(13i5,2i7)') jproc-1, nlcit (jproc), nlcjt(jproc), &587 & n ldit (jproc), nldjt(jproc), &588 & n leit (jproc), nlejt(jproc), &633 WRITE(inum,'(13i5,2i7)') jproc-1, jpiall(jproc), jpjall(jproc), & 634 & nis0all(jproc), njs0all(jproc), & 635 & nie0all(jproc), nje0all(jproc), & 589 636 & nimppt (jproc), njmppt (jproc), & 590 637 & ii_nono(jproc), ii_noso(jproc), & … … 620 667 WRITE(numout,*) ' l_Iperio = ', l_Iperio 621 668 WRITE(numout,*) ' l_Jperio = ', l_Jperio 622 WRITE(numout,*) ' nlci = ', nlci623 WRITE(numout,*) ' nlcj = ', nlcj624 669 WRITE(numout,*) ' nimpp = ', nimpp 625 670 WRITE(numout,*) ' njmpp = ', njmpp 626 WRITE(numout,*) ' nreci = ', nreci627 WRITE(numout,*) ' nrecj = ', nrecj628 WRITE(numout,*) ' nn_hls = ', nn_hls629 671 ENDIF 630 672 … … 648 690 ENDIF 649 691 ! 650 IF( ln_nnogather ) THEN 651 CALL mpp_init_nfdcom ! northfold neighbour lists 692 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 693 ! 694 IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 695 CALL init_nfdcom ! northfold neighbour lists 652 696 IF (llwrtlay) THEN 653 697 WRITE(inum,*) 654 698 WRITE(inum,*) 655 699 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 656 WRITE(inum,*) 'nfsloop : ', nfsloop657 WRITE(inum,*) 'nfeloop : ', nfeloop658 700 WRITE(inum,*) 'nsndto : ', nsndto 659 701 WRITE(inum,*) 'isendto : ', isendto … … 665 707 DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, & 666 708 & iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, & 667 & i lci, ilcj, ilei, ilej, ildi, ildj, &709 & ijpi, ijpj, iie0, ije0, iis0, ijs0, & 668 710 & iono, ioea, ioso, iowe, llisoce) 669 711 ! … … 671 713 672 714 673 SUBROUTINE mpp_bas ic_decomposition(knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj)674 !!---------------------------------------------------------------------- 675 !! *** ROUTINE mpp_bas ic_decomposition***715 SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) 716 !!---------------------------------------------------------------------- 717 !! *** ROUTINE mpp_basesplit *** 676 718 !! 677 719 !! ** Purpose : Lay out the global domain over processors. … … 685 727 !! klcj : second dimension 686 728 !!---------------------------------------------------------------------- 729 INTEGER, INTENT(in ) :: kiglo, kjglo 730 INTEGER, INTENT(in ) :: khls 687 731 INTEGER, INTENT(in ) :: knbi, knbj 688 732 INTEGER, INTENT( out) :: kimax, kjmax … … 691 735 ! 692 736 INTEGER :: ji, jj 737 INTEGER :: i2hls 693 738 INTEGER :: iresti, irestj, irm, ijpjmin 694 INTEGER :: ireci, irecj695 !!----------------------------------------------------------------------739 !!---------------------------------------------------------------------- 740 i2hls = 2*khls 696 741 ! 697 742 #if defined key_nemocice_decomp 698 kimax = ( nx_global+2- 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.699 kjmax = ( ny_global+2- 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.743 kimax = ( nx_global+2-i2hls + (knbi-1) ) / knbi + i2hls ! first dim. 744 kjmax = ( ny_global+2-i2hls + (knbj-1) ) / knbj + i2hls ! second dim. 700 745 #else 701 kimax = ( jpiglo - 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim.702 kjmax = ( jpjglo - 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim.746 kimax = ( kiglo - i2hls + (knbi-1) ) / knbi + i2hls ! first dim. 747 kjmax = ( kjglo - i2hls + (knbj-1) ) / knbj + i2hls ! second dim. 703 748 #endif 704 749 IF( .NOT. PRESENT(kimppt) ) RETURN … … 707 752 ! ----------------------------------- 708 753 ! Computation of local domain sizes klci() klcj() 709 ! These dimensions depend on global sizes knbi,knbj and jpiglo,jpjglo754 ! These dimensions depend on global sizes knbi,knbj and kiglo,kjglo 710 755 ! The subdomains are squares lesser than or equal to the global 711 756 ! dimensions divided by the number of processors minus the overlap array. 712 757 ! 713 ireci = 2 * nn_hls 714 irecj = 2 * nn_hls 715 iresti = 1 + MOD( jpiglo - ireci -1 , knbi ) 716 irestj = 1 + MOD( jpjglo - irecj -1 , knbj ) 758 iresti = 1 + MOD( kiglo - i2hls - 1 , knbi ) 759 irestj = 1 + MOD( kjglo - i2hls - 1 , knbj ) 717 760 ! 718 761 ! Need to use kimax and kjmax here since jpi and jpj not yet defined 719 762 #if defined key_nemocice_decomp 720 763 ! Change padding to be consistent with CICE 721 klci(1:knbi-1 ,:) = kimax722 klci( knbi ,:) = jpiglo - (knbi - 1) * (kimax - nreci)723 klcj(: ,1:knbj-1) = kjmax724 klcj(: , knbj) = jpjglo - (knbj - 1) * (kjmax - nrecj)764 klci(1:knbi-1,: ) = kimax 765 klci( knbi ,: ) = kiglo - (knbi - 1) * (kimax - i2hls) 766 klcj(: ,1:knbj-1) = kjmax 767 klcj(: , knbj ) = kjglo - (knbj - 1) * (kjmax - i2hls) 725 768 #else 726 769 klci(1:iresti ,:) = kimax 727 770 klci(iresti+1:knbi ,:) = kimax-1 728 IF( MINVAL(klci) < 3) THEN729 WRITE(ctmp1,*) ' mpp_bas ic_decomposition: minimum value of jpi must be >= 3'771 IF( MINVAL(klci) < 2*i2hls ) THEN 772 WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpi must be >= ', 2*i2hls 730 773 WRITE(ctmp2,*) ' We have ', MINVAL(klci) 731 774 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) … … 733 776 IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6 ) THEN 734 777 ! minimize the size of the last row to compensate for the north pole folding coast 735 IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 5 ! V and F folding involves line jpj-3 that must not be south boundary 736 IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 4 ! V and F folding involves line jpj-2 that must not be south boundary 737 irm = knbj - irestj ! total number of lines to be removed 738 klcj(:, knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 739 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 740 irestj = knbj - 1 - irm 741 klcj(:, 1:irestj) = kjmax 778 IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos 779 IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos 780 irm = knbj - irestj ! total number of lines to be removed 781 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 782 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 783 irestj = knbj - 1 - irm 742 784 klcj(:, irestj+1:knbj-1) = kjmax-1 743 785 ELSE 744 ijpjmin = 3 745 klcj(:, 1:irestj) = kjmax 746 klcj(:, irestj+1:knbj) = kjmax-1 747 ENDIF 748 IF( MINVAL(klcj) < ijpjmin ) THEN 749 WRITE(ctmp1,*) ' mpp_basic_decomposition: minimum value of jpj must be >= ', ijpjmin 786 klcj(:, irestj+1:knbj ) = kjmax-1 787 ENDIF 788 klcj(:,1:irestj) = kjmax 789 IF( MINVAL(klcj) < 2*i2hls ) THEN 790 WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpj must be >= ', 2*i2hls 750 791 WRITE(ctmp2,*) ' We have ', MINVAL(klcj) 751 792 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) … … 761 802 DO jj = 1, knbj 762 803 DO ji = 2, knbi 763 kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i reci804 kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i2hls 764 805 END DO 765 806 END DO … … 769 810 DO jj = 2, knbj 770 811 DO ji = 1, knbi 771 kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i recj812 kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i2hls 772 813 END DO 773 814 END DO 774 815 ENDIF 775 816 776 END SUBROUTINE mpp_bas ic_decomposition777 778 779 SUBROUTINE mpp_init_bestpartition( knbij, knbi, knbj, knbcnt, ldlist )780 !!---------------------------------------------------------------------- 781 !! *** ROUTINE mpp_init_bestpartition ***817 END SUBROUTINE mpp_basesplit 818 819 820 SUBROUTINE bestpartition( knbij, knbi, knbj, knbcnt, ldlist ) 821 !!---------------------------------------------------------------------- 822 !! *** ROUTINE bestpartition *** 782 823 !! 783 824 !! ** Purpose : … … 794 835 INTEGER :: isziref, iszjref 795 836 INTEGER :: inbij, iszij 796 INTEGER :: inbimax, inbjmax, inbijmax 837 INTEGER :: inbimax, inbjmax, inbijmax, inbijold 797 838 INTEGER :: isz0, isz1 798 839 INTEGER, DIMENSION( :), ALLOCATABLE :: indexok … … 821 862 inbimax = 0 822 863 inbjmax = 0 823 isziref = jpiglo*jpjglo+1824 iszjref = jpiglo*jpjglo+1864 isziref = Ni0glo*Nj0glo+1 865 iszjref = Ni0glo*Nj0glo+1 825 866 ! 826 867 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 830 871 iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 831 872 #else 832 iszitst = ( jpiglo - 2*nn_hls + (ji-1) ) / ji + 2*nn_hls873 iszitst = ( Ni0glo + (ji-1) ) / ji 833 874 #endif 834 875 IF( iszitst < isziref ) THEN … … 841 882 iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. 842 883 #else 843 iszjtst = ( jpjglo - 2*nn_hls + (ji-1) ) / ji + 2*nn_hls884 iszjtst = ( Nj0glo + (ji-1) ) / ji 844 885 #endif 845 886 IF( iszjtst < iszjref ) THEN … … 881 922 iszij1(:) = iszi1(:) * iszj1(:) 882 923 883 ! if ther ris no land and no print884 IF( .NOT. llist .AND. numbot == -1 ) THEN924 ! if there is no land and no print 925 IF( .NOT. llist .AND. numbot == -1 .AND. numbdy == -1 ) THEN 885 926 ! get the smaller partition which gives the smallest subdomain size 886 927 ii = MINLOC(inbij1, mask = iszij1 == MINVAL(iszij1), dim = 1) … … 896 937 isz0 = 0 ! number of best partitions 897 938 inbij = 1 ! start with the min value of inbij1 => 1 898 iszij = jpiglo*jpjglo+1 ! default: larger than global domain939 iszij = Ni0glo*Nj0glo+1 ! default: larger than global domain 899 940 DO WHILE( inbij <= inbijmax ) ! if we did not reach the max of inbij1 900 941 ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1) ! warning: send back the first occurence if multiple results … … 919 960 DEALLOCATE( indexok, inbi1, inbj1, iszi1, iszj1 ) 920 961 921 IF( llist ) THEN ! we print about 21 best partitions962 IF( llist ) THEN 922 963 IF(lwp) THEN 923 964 WRITE(numout,*) 924 WRITE(numout, 925 WRITE(numout, '(a,i5,a)') ' list of the best partitions around ', knbij, ' mpi processes'926 WRITE(numout, *) ' --------------------------------------', '-----', '--------------'965 WRITE(numout,*) ' For your information:' 966 WRITE(numout,*) ' list of the best partitions including land supression' 967 WRITE(numout,*) ' -----------------------------------------------------' 927 968 WRITE(numout,*) 928 969 END IF 929 iitarget = MINLOC( inbi0(:)*inbj0(:), mask = inbi0(:)*inbj0(:) >= knbij, dim = 1 ) 930 DO ji = MAX(1,iitarget-10), MIN(isz0,iitarget+10) 970 ji = isz0 ! initialization with the largest value 971 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 972 CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum) 973 inbijold = COUNT(llisoce) 974 DEALLOCATE( llisoce ) 975 DO ji =isz0-1,1,-1 931 976 ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 932 CALL mpp_i nit_isoce( inbi0(ji), inbj0(ji), llisoce )! Warning: must be call by all cores (call mpp_sum)977 CALL mpp_is_ocean( llisoce ) ! Warning: must be call by all cores (call mpp_sum) 933 978 inbij = COUNT(llisoce) 934 979 DEALLOCATE( llisoce ) 935 IF(lwp) WRITE(numout,'(a, i5, a, i5, a, i4, a, i4, a, i9, a, i5, a, i5, a)') & 936 & 'nb_cores ' , inbij,' oce + ', inbi0(ji)*inbj0(ji) - inbij & 937 & , ' land ( ', inbi0(ji),' x ', inbj0(ji), & 938 & ' ), nb_points ', iszi0(ji)*iszj0(ji),' ( ', iszi0(ji),' x ', iszj0(ji),' )' 980 IF(lwp .AND. inbij < inbijold) THEN 981 WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & 982 & 'nb_cores oce: ', inbij, ', land domains excluded: ', inbi0(ji)*inbj0(ji) - inbij, & 983 & ' (', REAL(inbi0(ji)*inbj0(ji) - inbij,wp) / REAL(inbi0(ji)*inbj0(ji),wp) *100., & 984 & '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 985 inbijold = inbij 986 END IF 939 987 END DO 940 988 DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) 941 RETURN 989 IF(lwp) THEN 990 WRITE(numout,*) 991 WRITE(numout,*) ' -----------------------------------------------------------' 992 ENDIF 993 CALL mppsync 994 CALL mppstop( ld_abort = .TRUE. ) 942 995 ENDIF 943 996 … … 948 1001 ii = ii -1 949 1002 ALLOCATE( llisoce(inbi0(ii), inbj0(ii)) ) 950 CALL mpp_i nit_isoce( inbi0(ii), inbj0(ii),llisoce ) ! must be done by all core1003 CALL mpp_is_ocean( llisoce ) ! must be done by all core 951 1004 inbij = COUNT(llisoce) 952 1005 DEALLOCATE( llisoce ) … … 957 1010 DEALLOCATE( inbi0, inbj0 ) 958 1011 ! 959 END SUBROUTINE mpp_init_bestpartition1012 END SUBROUTINE bestpartition 960 1013 961 1014 … … 966 1019 !! ** Purpose : the the proportion of land points in the surface land-sea mask 967 1020 !! 968 !! ** Method : read iproc strips (of length jpiglo) of the land-sea mask1021 !! ** Method : read iproc strips (of length Ni0glo) of the land-sea mask 969 1022 !!---------------------------------------------------------------------- 970 1023 REAL(wp), INTENT( out) :: propland ! proportion of land points in the global domain (between 0 and 1) … … 977 1030 !!---------------------------------------------------------------------- 978 1031 ! do nothing if there is no land-sea mask 979 IF( numbot == -1 ) THEN1032 IF( numbot == -1 .and. numbdy == -1 ) THEN 980 1033 propland = 0. 981 1034 RETURN … … 983 1036 984 1037 ! number of processes reading the bathymetry file 985 iproc = MINVAL( (/mppsize, jpjglo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time1038 iproc = MINVAL( (/mppsize, Nj0glo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time 986 1039 987 1040 ! we want to read iproc strips of the land-sea mask. -> pick up iproc processes every idiv processes starting at 1 … … 993 1046 IF( MOD( narea-1, idiv ) == 0 .AND. iarea < iproc ) THEN ! beware idiv can be = to 1 994 1047 ! 995 ijsz = jpjglo / iproc ! width of the stripe to read996 IF( iarea < MOD( jpjglo,iproc) ) ijsz = ijsz + 1997 ijstr = iarea*( jpjglo/iproc) + MIN(iarea, MOD(jpjglo,iproc)) + 1 ! starting j position of the reading998 ! 999 ALLOCATE( lloce( jpiglo, ijsz) ) ! allocate the strip1000 CALL mpp_init_readbot_strip( ijstr, ijsz, lloce )1048 ijsz = Nj0glo / iproc ! width of the stripe to read 1049 IF( iarea < MOD(Nj0glo,iproc) ) ijsz = ijsz + 1 1050 ijstr = iarea*(Nj0glo/iproc) + MIN(iarea, MOD(Nj0glo,iproc)) + 1 ! starting j position of the reading 1051 ! 1052 ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip 1053 CALL readbot_strip( ijstr, ijsz, lloce ) 1001 1054 inboce = COUNT(lloce) ! number of ocean point in the stripe 1002 1055 DEALLOCATE(lloce) … … 1007 1060 CALL mpp_sum( 'mppini', inboce ) ! total number of ocean points over the global domain 1008 1061 ! 1009 propland = REAL( jpiglo*jpjglo - inboce, wp ) / REAL( jpiglo*jpjglo, wp )1062 propland = REAL( Ni0glo*Nj0glo - inboce, wp ) / REAL( Ni0glo*Nj0glo, wp ) 1010 1063 ! 1011 1064 END SUBROUTINE mpp_init_landprop 1012 1065 1013 1066 1014 SUBROUTINE mpp_init_isoce( knbi, knbj, ldisoce ) 1015 !!---------------------------------------------------------------------- 1016 !! *** ROUTINE mpp_init_nboce *** 1017 !! 1018 !! ** Purpose : check for a mpi domain decomposition knbi x knbj which 1019 !! subdomains contain at least 1 ocean point 1020 !! 1021 !! ** Method : read knbj strips (of length jpiglo) of the land-sea mask 1022 !!---------------------------------------------------------------------- 1023 INTEGER, INTENT(in ) :: knbi, knbj ! domain decomposition 1024 LOGICAL, DIMENSION(knbi,knbj), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point 1025 ! 1026 INTEGER, DIMENSION(knbi,knbj) :: inboce ! number oce oce pint in each mpi subdomain 1027 INTEGER, DIMENSION(knbi*knbj) :: inboce_1d 1067 SUBROUTINE mpp_is_ocean( ldisoce ) 1068 !!---------------------------------------------------------------------- 1069 !! *** ROUTINE mpp_is_ocean *** 1070 !! 1071 !! ** Purpose : Check for a mpi domain decomposition inbi x inbj which 1072 !! subdomains, including 1 halo (even if nn_hls>1), contain 1073 !! at least 1 ocean point. 1074 !! We must indeed ensure that each subdomain that is a neighbour 1075 !! of a land subdomain as only land points on its boundary 1076 !! (inside the inner subdomain) with the land subdomain. 1077 !! This is needed to get the proper bondary conditions on 1078 !! a subdomain with a closed boundary. 1079 !! 1080 !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask 1081 !!---------------------------------------------------------------------- 1082 LOGICAL, DIMENSION(:,:), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point 1083 ! 1028 1084 INTEGER :: idiv, iimax, ijmax, iarea 1085 INTEGER :: inbi, inbj, inx, iny, inry, isty 1029 1086 INTEGER :: ji, jn 1030 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean 1031 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ilci 1032 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ilcj 1087 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: inboce ! number oce oce pint in each mpi subdomain 1088 INTEGER, ALLOCATABLE, DIMENSION(: ) :: inboce_1d 1089 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi 1090 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj 1091 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean 1033 1092 !!---------------------------------------------------------------------- 1034 1093 ! do nothing if there is no land-sea mask 1035 IF( numbot == -1 ) THEN1094 IF( numbot == -1 .AND. numbdy == -1 ) THEN 1036 1095 ldisoce(:,:) = .TRUE. 1037 1096 RETURN 1038 1097 ENDIF 1039 1040 ! we want to read knbj strips of the land-sea mask. -> pick up knbj processes every idiv processes starting at 1 1041 IF ( knbj == 1 ) THEN ; idiv = mppsize 1042 ELSE IF ( mppsize < knbj ) THEN ; idiv = 1 1043 ELSE ; idiv = ( mppsize - 1 ) / ( knbj - 1 ) 1044 ENDIF 1098 ! 1099 inbi = SIZE( ldisoce, dim = 1 ) 1100 inbj = SIZE( ldisoce, dim = 2 ) 1101 ! 1102 ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 1103 IF ( inbj == 1 ) THEN ; idiv = mppsize 1104 ELSE IF ( mppsize < inbj ) THEN ; idiv = 1 1105 ELSE ; idiv = ( mppsize - 1 ) / ( inbj - 1 ) 1106 ENDIF 1107 ! 1108 ALLOCATE( inboce(inbi,inbj), inboce_1d(inbi*inbj) ) 1045 1109 inboce(:,:) = 0 ! default no ocean point found 1046 1047 DO jn = 0, ( knbj-1)/mppsize ! if mppsize < knbj : more strips than mpi processes (because of potential land domains)1048 ! 1049 iarea = (narea-1)/idiv + jn * mppsize ! involed process number (starting counting at 0)1050 IF( MOD( narea-1, idiv ) == 0 .AND. iarea < knbj ) THEN! beware idiv can be = to 11110 ! 1111 DO jn = 0, (inbj-1)/mppsize ! if mppsize < inbj : more strips than mpi processes (because of potential land domains) 1112 ! 1113 iarea = (narea-1)/idiv + jn * mppsize + 1 ! involed process number (starting counting at 1) 1114 IF( MOD( narea-1, idiv ) == 0 .AND. iarea <= inbj ) THEN ! beware idiv can be = to 1 1051 1115 ! 1052 ALLOCATE( iimppt( knbi,knbj), ijmppt(knbi,knbj), ilci(knbi,knbj), ilcj(knbi,knbj) )1053 CALL mpp_bas ic_decomposition( knbi, knbj, iimax, ijmax, iimppt, ijmppt, ilci, ilcj )1116 ALLOCATE( iimppt(inbi,inbj), ijmppt(inbi,inbj), ijpi(inbi,inbj), ijpj(inbi,inbj) ) 1117 CALL mpp_basesplit( Ni0glo, Nj0glo, 0, inbi, inbj, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj ) 1054 1118 ! 1055 ALLOCATE( lloce(jpiglo, ilcj(1,iarea+1)) ) ! allocate the strip 1056 CALL mpp_init_readbot_strip( ijmppt(1,iarea+1), ilcj(1,iarea+1), lloce ) ! read the strip 1057 DO ji = 1, knbi 1058 inboce(ji,iarea+1) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ilci(ji,1)-1,:) ) ! number of ocean point in subdomain 1119 inx = Ni0glo + 2 ; iny = ijpj(1,iarea) + 2 ! strip size + 1 halo on each direction (even if nn_hls>1) 1120 ALLOCATE( lloce(inx, iny) ) ! allocate the strip 1121 inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction 1122 isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line? 1123 CALL readbot_strip( ijmppt(1,iarea) - 2 + isty, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip 1124 ! 1125 IF( iarea == 1 ) THEN ! the first line was not read 1126 IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity 1127 CALL readbot_strip( Nj0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce 1128 ELSE 1129 lloce(2:inx-1, 1) = .FALSE. ! closed boundary 1130 ENDIF 1131 ENDIF 1132 IF( iarea == inbj ) THEN ! the last line was not read 1133 IF( jperio == 2 .OR. jperio == 7 ) THEN ! north-south periodocity 1134 CALL readbot_strip( 1, 1, lloce(2:inx-1,iny) ) ! read the first line -> last line of lloce 1135 ELSEIF( jperio == 3 .OR. jperio == 4 ) THEN ! north-pole folding T-pivot, T-point 1136 lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1) 1137 DO ji = 3,inx-1 1138 lloce(ji,iny ) = lloce(inx-ji+2,iny-2) ! ok, we have at least 3 lines 1139 END DO 1140 DO ji = inx/2+2,inx-1 1141 lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) 1142 END DO 1143 ELSEIF( jperio == 5 .OR. jperio == 6 ) THEN ! north-pole folding F-pivot, T-point, 1 halo 1144 lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1) 1145 lloce(inx -1,iny-1) = lloce(2 ,iny-1) 1146 DO ji = 2,inx-1 1147 lloce(ji,iny) = lloce(inx-ji+1,iny-1) 1148 END DO 1149 ELSE ! closed boundary 1150 lloce(2:inx-1,iny) = .FALSE. 1151 ENDIF 1152 ENDIF 1153 ! ! first and last column were not read 1154 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 1155 lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity 1156 ELSE 1157 lloce(1,:) = .FALSE. ; lloce(inx,:) = .FALSE. ! closed boundary 1158 ENDIF 1159 ! 1160 DO ji = 1, inbi 1161 inboce(ji,iarea) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ijpi(ji,1)+1,:) ) ! lloce as 2 points more than Ni0glo 1059 1162 END DO 1060 1163 ! 1061 1164 DEALLOCATE(lloce) 1062 DEALLOCATE(iimppt, ijmppt, i lci, ilcj)1165 DEALLOCATE(iimppt, ijmppt, ijpi, ijpj) 1063 1166 ! 1064 1167 ENDIF 1065 1168 END DO 1066 1169 1067 inboce_1d = RESHAPE(inboce, (/ knbi*knbj /))1170 inboce_1d = RESHAPE(inboce, (/ inbi*inbj /)) 1068 1171 CALL mpp_sum( 'mppini', inboce_1d ) 1069 inboce = RESHAPE(inboce_1d, (/ knbi, knbj/))1172 inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 1070 1173 ldisoce(:,:) = inboce(:,:) /= 0 1071 ! 1072 END SUBROUTINE mpp_init_isoce 1174 DEALLOCATE(inboce, inboce_1d) 1175 ! 1176 END SUBROUTINE mpp_is_ocean 1073 1177 1074 1178 1075 SUBROUTINE mpp_init_readbot_strip( kjstr, kjcnt, ldoce )1076 !!---------------------------------------------------------------------- 1077 !! *** ROUTINE mpp_init_readbot_strip ***1179 SUBROUTINE readbot_strip( kjstr, kjcnt, ldoce ) 1180 !!---------------------------------------------------------------------- 1181 !! *** ROUTINE readbot_strip *** 1078 1182 !! 1079 1183 !! ** Purpose : Read relevant bathymetric information in order to … … 1081 1185 !! of land domains, in an mpp computation. 1082 1186 !! 1083 !! ** Method : read stipe of size ( jpiglo,...)1084 !!---------------------------------------------------------------------- 1085 INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading1086 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read1087 LOGICAL, DIMENSION( jpiglo,kjcnt), INTENT( out) ::ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean1187 !! ** Method : read stipe of size (Ni0glo,...) 1188 !!---------------------------------------------------------------------- 1189 INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading 1190 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read 1191 LOGICAL, DIMENSION(Ni0glo,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean 1088 1192 ! 1089 1193 INTEGER :: inumsave ! local logical unit 1090 REAL(wp), DIMENSION( jpiglo,kjcnt) :: zbot1194 REAL(wp), DIMENSION(Ni0glo,kjcnt) :: zbot, zbdy 1091 1195 !!---------------------------------------------------------------------- 1092 1196 ! 1093 1197 inumsave = numout ; numout = numnul ! redirect all print to /dev/null 1094 1198 ! 1095 IF( numbot /= -1 ) THEN 1096 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/ jpiglo, kjcnt/) )1199 IF( numbot /= -1 ) THEN 1200 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 1097 1201 ELSE 1098 zbot(:,:) = 1. ! put a non-null value 1099 ENDIF 1100 1101 ! 1102 ldoce(:,:) = zbot(:,:) > 0. 1202 zbot(:,:) = 1._wp ! put a non-null value 1203 ENDIF 1204 ! 1205 IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists 1206 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 1207 zbot(:,:) = zbot(:,:) * zbdy(:,:) 1208 ENDIF 1209 ! 1210 ldoce(:,:) = zbot(:,:) > 0._wp 1103 1211 numout = inumsave 1104 1212 ! 1105 END SUBROUTINE mpp_init_readbot_strip 1106 1107 SUBROUTINE mpp_init_nfdcom 1108 !!---------------------------------------------------------------------- 1109 !! *** ROUTINE mpp_init_nfdcom *** 1213 END SUBROUTINE readbot_strip 1214 1215 1216 SUBROUTINE mpp_getnum( ldisoce, kproc, kipos, kjpos ) 1217 !!---------------------------------------------------------------------- 1218 !! *** ROUTINE mpp_getnum *** 1219 !! 1220 !! ** Purpose : give a number to each MPI subdomains (starting at 0) 1221 !! 1222 !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed 1223 !!---------------------------------------------------------------------- 1224 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldisoce ! F if land process 1225 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if supressed, starting at 0) 1226 INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) 1227 INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) 1228 ! 1229 INTEGER :: ii, ij, jarea, iarea0 1230 INTEGER :: icont, i2add , ini, inj, inij 1231 !!---------------------------------------------------------------------- 1232 ! 1233 ini = SIZE(ldisoce, dim = 1) 1234 inj = SIZE(ldisoce, dim = 2) 1235 inij = SIZE(kipos) 1236 ! 1237 ! specify which subdomains are oce subdomains; other are land subdomains 1238 kproc(:,:) = -1 1239 icont = -1 1240 DO jarea = 1, ini*inj 1241 iarea0 = jarea - 1 1242 ii = 1 + MOD(iarea0,ini) 1243 ij = 1 + iarea0/ini 1244 IF( ldisoce(ii,ij) ) THEN 1245 icont = icont + 1 1246 kproc(ii,ij) = icont 1247 kipos(icont+1) = ii 1248 kjpos(icont+1) = ij 1249 ENDIF 1250 END DO 1251 ! if needed add some land subdomains to reach inij active subdomains 1252 i2add = inij - COUNT( ldisoce ) 1253 DO jarea = 1, ini*inj 1254 iarea0 = jarea - 1 1255 ii = 1 + MOD(iarea0,ini) 1256 ij = 1 + iarea0/ini 1257 IF( .NOT. ldisoce(ii,ij) .AND. i2add > 0 ) THEN 1258 icont = icont + 1 1259 kproc(ii,ij) = icont 1260 kipos(icont+1) = ii 1261 kjpos(icont+1) = ij 1262 i2add = i2add - 1 1263 ENDIF 1264 END DO 1265 ! 1266 END SUBROUTINE mpp_getnum 1267 1268 1269 SUBROUTINE init_ioipsl 1270 !!---------------------------------------------------------------------- 1271 !! *** ROUTINE init_ioipsl *** 1272 !! 1273 !! ** Purpose : 1274 !! 1275 !! ** Method : 1276 !! 1277 !! History : 1278 !! 9.0 ! 04-03 (G. Madec ) MPP-IOIPSL 1279 !! " " ! 08-12 (A. Coward) addition in case of jpni*jpnj < jpnij 1280 !!---------------------------------------------------------------------- 1281 INTEGER, DIMENSION(2) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid 1282 !!---------------------------------------------------------------------- 1283 1284 ! The domain is split only horizontally along i- or/and j- direction 1285 ! So we need at the most only 1D arrays with 2 elements. 1286 ! Set idompar values equivalent to the jpdom_local_noextra definition 1287 ! used in IOM. This works even if jpnij .ne. jpni*jpnj. 1288 iglo( :) = (/ Ni0glo, Nj0glo /) 1289 iloc( :) = (/ Ni_0 , Nj_0 /) 1290 iabsf(:) = (/ Nis0 , Njs0 /) + (/ nimpp, njmpp /) - 1 - nn_hls ! corresponds to mig0(Nis0) but mig0 is not yet defined! 1291 iabsl(:) = iabsf(:) + iloc(:) - 1 1292 ihals(:) = (/ 0 , 0 /) 1293 ihale(:) = (/ 0 , 0 /) 1294 idid( :) = (/ 1 , 2 /) 1295 1296 IF(lwp) THEN 1297 WRITE(numout,*) 1298 WRITE(numout,*) 'mpp init_ioipsl : iloc = ', iloc 1299 WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf 1300 WRITE(numout,*) ' ihals = ', ihals 1301 WRITE(numout,*) ' ihale = ', ihale 1302 ENDIF 1303 ! 1304 CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) 1305 ! 1306 END SUBROUTINE init_ioipsl 1307 1308 1309 SUBROUTINE init_nfdcom 1310 !!---------------------------------------------------------------------- 1311 !! *** ROUTINE init_nfdcom *** 1110 1312 !! ** Purpose : Setup for north fold exchanges with explicit 1111 1313 !! point-to-point messaging … … 1117 1319 !!---------------------------------------------------------------------- 1118 1320 INTEGER :: sxM, dxM, sxT, dxT, jn 1119 INTEGER :: njmppmax 1120 !!---------------------------------------------------------------------- 1121 ! 1122 njmppmax = MAXVAL( njmppt ) 1321 !!---------------------------------------------------------------------- 1123 1322 ! 1124 1323 !initializes the north-fold communication variables … … 1126 1325 nsndto = 0 1127 1326 ! 1128 IF ( njmpp == njmppmax) THEN ! if I am a process in the north1327 IF ( njmpp == MAXVAL( njmppt ) ) THEN ! if I am a process in the north 1129 1328 ! 1130 1329 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1131 sxM = jpiglo - nimppt(narea) - nlcit(narea) + 11330 sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 1132 1331 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1133 1332 dxM = jpiglo - nimppt(narea) + 2 … … 1138 1337 DO jn = 1, jpni 1139 1338 ! 1140 sxT = nfi impp(jn, jpnj)! sxT = 1st point (in the global domain) of the jn process1141 dxT = nfi impp(jn, jpnj) + nfilcit(jn, jpnj) - 1 ! dxT = last point (in the global domain) of the jn process1339 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1340 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1142 1341 ! 1143 1342 IF ( sxT < sxM .AND. sxM < dxT ) THEN … … 1153 1352 ! 1154 1353 END DO 1155 nfsloop = 11156 nfeloop = nlci1157 DO jn = 2,jpni-11158 IF( nfipproc(jn,jpnj) == (narea - 1) ) THEN1159 IF( nfipproc(jn-1,jpnj) == -1 ) nfsloop = nldi1160 IF( nfipproc(jn+1,jpnj) == -1 ) nfeloop = nlei1161 ENDIF1162 END DO1163 1354 ! 1164 1355 ENDIF 1165 1356 l_north_nogather = .TRUE. 1166 1357 ! 1167 END SUBROUTINE mpp_init_nfdcom 1168 1358 END SUBROUTINE init_nfdcom 1169 1359 1170 1360 #endif 1171 1361 1362 SUBROUTINE init_doloop 1363 !!---------------------------------------------------------------------- 1364 !! *** ROUTINE init_doloop *** 1365 !! 1366 !! ** Purpose : set the starting/ending indices of DO-loop 1367 !! These indices are used in do_loop_substitute.h90 1368 !!---------------------------------------------------------------------- 1369 ! 1370 Nis0 = 1+nn_hls ; Nis1 = Nis0-1 ; Nis2 = MAX( 1, Nis0-2) 1371 Njs0 = 1+nn_hls ; Njs1 = Njs0-1 ; Njs2 = MAX( 1, Njs0-2) 1372 ! 1373 Nie0 = jpi-nn_hls ; Nie1 = Nie0+1 ; Nie2 = MIN(jpi, Nie0+2) 1374 Nje0 = jpj-nn_hls ; Nje1 = Nje0+1 ; Nje2 = MIN(jpj, Nje0+2) 1375 ! 1376 IF( nn_hls == 1 ) THEN !* halo size of 1 1377 ! 1378 Nis1nxt2 = Nis0 ; Njs1nxt2 = Njs0 1379 Nie1nxt2 = Nie0 ; Nje1nxt2 = Nje0 1380 ! 1381 ELSE !* larger halo size... 1382 ! 1383 Nis1nxt2 = Nis1 ; Njs1nxt2 = Njs1 1384 Nie1nxt2 = Nie1 ; Nje1nxt2 = Nje1 1385 ! 1386 ENDIF 1387 ! 1388 Ni_0 = Nie0 - Nis0 + 1 1389 Nj_0 = Nje0 - Njs0 + 1 1390 Ni_1 = Nie1 - Nis1 + 1 1391 Nj_1 = Nje1 - Njs1 + 1 1392 Ni_2 = Nie2 - Nis2 + 1 1393 Nj_2 = Nje2 - Njs2 + 1 1394 ! 1395 END SUBROUTINE init_doloop 1396 1172 1397 !!====================================================================== 1173 1398 END MODULE mppini -
utils/tools/DOMAINcfg/src/nc4interface.f90
r6951 r14623 5 5 ! See IOIPSL/IOIPSL_License_CeCILL.txt 6 6 !--------------------------------------------------------------------- 7 7 #if ! defined key_netcdf4 8 8 !!-------------------------------------------------------------------- 9 9 !! NOT 'key_netcdf4' Defines dummy routines for netcdf4 … … 51 51 SET_NF90_DEF_VAR_DEFLATE = -1 52 52 END FUNCTION SET_NF90_DEF_VAR_DEFLATE 53 #else 54 !!-------------------------------------------------------------------- 55 !! 'key_netcdf4' Dummy module (usually defines dummy routines for netcdf4 56 !! calls when compiling without netcdf4 libraries 57 !!-------------------------------------------------------------------- 58 59 USE netcdf 60 61 !- netcdf4 chunking control structure 62 !- (optional on histbeg and histend calls) 63 !$AGRIF_DO_NOT_TREAT 64 TYPE, PUBLIC :: snc4_ctl 65 SEQUENCE 66 INTEGER :: ni 67 INTEGER :: nj 68 INTEGER :: nk 69 LOGICAL :: luse 70 END TYPE snc4_ctl 71 !$AGRIF_END_DO_NOT_TREAT 72 73 CONTAINS 74 INTEGER FUNCTION SET_NF90_DEF_VAR_CHUNKING(nfid, nvid, ichunkalg, ichunksz) 75 !!-------------------------------------------------------------------- 76 !! *** SUBROUTINE NF90_DEF_VAR_CHUNKING *** 77 !! 78 !! ** Purpose : Interface NetCDF4 routine to enable compiling with NetCDF4 libraries 79 !! but no key_netcdf4 80 !!-------------------------------------------------------------------- 81 INTEGER, INTENT(in) :: nfid 82 INTEGER, INTENT(in) :: nvid 83 INTEGER, INTENT(in) :: ichunkalg 84 INTEGER, DIMENSION(:), INTENT(in) :: ichunksz 85 !! 86 INTEGER :: iret 87 !! 88 iret = NF90_DEF_VAR_CHUNKING(nfid, nvid, ichunkalg, ichunksz) 89 SET_NF90_DEF_VAR_CHUNKING = iret 90 END FUNCTION SET_NF90_DEF_VAR_CHUNKING 91 92 INTEGER FUNCTION SET_NF90_DEF_VAR_DEFLATE(nfid, nvid, ishuffle, ideflate, ideflate_level) 93 !!-------------------------------------------------------------------- 94 !! *** SUBROUTINE NF90_DEF_VAR_DEFLATE *** 95 !! 96 !! ** Purpose : Interface NetCDF4 routine to enable compiling with NetCDF4 libraries 97 !! but no key_netcdf4 98 !!-------------------------------------------------------------------- 99 INTEGER, INTENT(in) :: nfid 100 INTEGER, INTENT(in) :: nvid 101 INTEGER, INTENT(in) :: ishuffle 102 INTEGER, INTENT(in) :: ideflate 103 INTEGER, INTENT(in) :: ideflate_level 104 !! 105 INTEGER :: iret 106 !! 107 iret = NF90_DEF_VAR_DEFLATE(nfid, nvid, ishuffle, ideflate, ideflate_level) 108 SET_NF90_DEF_VAR_DEFLATE = iret 109 END FUNCTION SET_NF90_DEF_VAR_DEFLATE 110 111 SUBROUTINE GET_NF90_SYMBOL(sym_name, ivalue) 112 CHARACTER(len=*), INTENT(in) :: sym_name 113 INTEGER, INTENT(out) :: ivalue 114 SELECT CASE (sym_name) 115 CASE ("NF90_HDF5") 116 ivalue = NF90_HDF5 117 CASE DEFAULT 118 WRITE(*,*) "Warning: unknown case in GET_NF90_SYMBOL" 119 END SELECT 120 END SUBROUTINE GET_NF90_SYMBOL 121 #endif 53 122 54 123 !------------------ -
utils/tools/DOMAINcfg/src/nemogcm.F90
r13204 r14623 54 54 USE lib_mpp ! distributed memory computing 55 55 56 USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges57 56 58 57 USE agrif_connect 59 58 USE agrif_dom_update 60 59 USE agrif_recompute_scales 60 61 USE halo_mng 61 62 62 63 IMPLICIT NONE … … 106 107 107 108 CALL Agrif_Step_Child_adj(agrif_update_all) 108 109 109 110 CALL Agrif_Step_Child(agrif_recompute_scalefactors) 110 111 … … 122 123 ! !------------------------! 123 124 ! 124 IF( nstop /= 0 .AND. lwp ) THEN ! error print 125 WRITE(numout,cform_err) 126 WRITE(numout,*) nstop, ' error have been found' 125 IF( nstop /= 0 .AND. lwp ) THEN ! error print 126 ngrdstop = Agrif_Fixed() 127 WRITE(ctmp1,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found' 128 IF( ngrdstop > 0 ) THEN 129 WRITE(ctmp9,'(i2)') ngrdstop 130 WRITE(ctmp2,*) ' E R R O R detected in Agrif grid '//TRIM(ctmp9) 131 WRITE(ctmp3,*) ' Look for "E R R O R" messages in all existing '//TRIM(ctmp9)//'_ocean_output* files' 132 CALL ctl_stop( ' ', ctmp1, ' ', ctmp2, ' ', ctmp3 ) 133 ELSE 134 WRITE(ctmp2,*) ' Look for "E R R O R" messages in all existing ocean_output* files' 135 CALL ctl_stop( ' ', ctmp1, ' ', ctmp2 ) 136 ENDIF 127 137 ENDIF 128 138 ! … … 144 154 CHARACTER(len=120), DIMENSION(60) :: cltxt, cltxt2, clnam 145 155 !! 156 NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, & 157 & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle 146 158 NAMELIST/namcfg/ ln_e3_dep, & 147 & cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, & 148 & jperio, ln_use_jattr, ln_domclo 149 !!---------------------------------------------------------------------- 150 ! 159 & cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, Ni0glo, Nj0glo, & 160 & jpkglo, jperio, ln_use_jattr, ln_domclo 161 !!---------------------------------------------------------------------- 162 ! 163 164 ! 165 ! !-------------------------------------------------! 166 ! ! set communicator & select the local rank ! 167 ! ! must be done as soon as possible to get narea ! 168 ! !-------------------------------------------------! 169 ! 170 #if defined key_iomput 171 IF( Agrif_Root() ) THEN 172 IF( lk_oasis ) THEN 173 CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis 174 CALL xios_initialize( "not used" , local_comm =ilocal_comm ) ! send nemo communicator to xios 175 ELSE 176 CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm ) ! nemo local communicator given by xios 177 ENDIF 178 ENDIF 179 CALL mpp_start( ilocal_comm ) 180 #else 181 ! IF( lk_oasis ) THEN 182 ! IF( Agrif_Root() ) THEN 183 ! CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis 184 ! ENDIF 185 ! CALL mpp_start( ilocal_comm ) 186 ! ELSE 187 CALL mpp_start( ) 188 ! ENDIF 189 #endif 190 ! 191 narea = mpprank + 1 ! mpprank: the rank of proc (0 --> mppsize -1 ) 192 lwm = (narea == 1) ! control of output namelists 193 151 194 cltxt = '' 152 195 ! 153 ! ! Open reference namelist and configuration namelist files 154 CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 155 CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 156 ! 157 REWIND( numnam_ref ) ! Namelist namcfg in reference namelist 196 ! 197 ! !---------------------------------------------------------------! 198 ! ! Open output files, reference and configuration namelist files ! 199 ! !---------------------------------------------------------------! 200 ! 201 ! open ocean.output as soon as possible to get all output prints (including errors messages) 202 IF( lwm ) CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 203 ! open reference and configuration namelist files 204 CALL load_nml( numnam_ref, 'namelist_ref', -1, lwm ) 205 CALL load_nml( numnam_cfg, 'namelist_cfg', -1, lwm ) 206 IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 207 ! open /dev/null file to be able to supress output write easily 208 IF( Agrif_Root() ) THEN 209 CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 210 #ifdef key_agrif 211 ELSE 212 numnul = Agrif_Parent(numnul) 213 #endif 214 ENDIF 215 158 216 READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) 159 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. ) 160 REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist 217 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist') 161 218 READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 162 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. ) 163 164 ! Force values for AGRIF zoom (cf. agrif_user.F90) 165 ! 166 ! !--------------------------------------------! 167 ! ! set communicator & select the local node ! 168 ! ! NB: mynode also opens output.namelist.dyn ! 169 ! ! on unit number numond on first proc ! 170 ! !--------------------------------------------! 171 ! Nodes selection (control print return in cltxt) 172 narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop ) 173 narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 ) 174 175 lwm = (narea == 1) ! control of output namelists 219 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist') 220 176 221 lwp = (narea == 1) ! control of all listing output print 177 222 … … 183 228 ENDIF 184 229 185 IF(lwp) THEN ! open listing units 186 ! 187 CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 230 ! !--------------------! 231 ! ! Open listing units ! -> need sn_cfctl from namctl to define lwp 232 ! !--------------------! 233 ! 234 READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) 235 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist' ) 236 READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) 237 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist' ) 238 ! 239 ! finalize the definition of namctl variables 240 IF( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax .OR. MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) & 241 & CALL nemo_set_cfctl( sn_cfctl, .FALSE. ) 242 ! 243 lwp = (narea == 1) .OR. sn_cfctl%l_oceout ! control of all listing output print 244 ! 245 IF(lwp) THEN ! open listing units 246 ! 247 IF( .NOT. lwm ) & ! alreay opened for narea == 1 248 & CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) 188 249 ! 189 250 WRITE(numout,*) 190 WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV -CMCC'251 WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC' 191 252 WRITE(numout,*) ' NEMO team' 192 253 WRITE(numout,*) ' Ocean General Circulation Model' … … 204 265 WRITE(numout,*) " ) ) \) |`\ \) '. \ ( ( " 205 266 WRITE(numout,*) " ( ( \_/ '-._\ ) ) " 206 WRITE(numout,*) " ) ) `( ( "267 WRITE(numout,*) " ) ) jgs ` ( ( " 207 268 WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 208 269 WRITE(numout,*) 209 270 210 DO ji = 1, SIZE(cltxt) 211 IF( TRIM(cltxt (ji)) /= '' ) WRITE(numout,*) TRIM(cltxt(ji)) ! control print of mynode 212 END DO 271 ! Print the working precision to ocean.output 272 IF (wp == dp) THEN 273 WRITE(numout,*) "Working precision = double-precision" 274 ELSE 275 WRITE(numout,*) "Working precision = single-precision" 276 ENDIF 213 277 WRITE(numout,*) 214 WRITE(numout,*)215 ! DO ji = 1, SIZE(cltxt2)216 ! IF( TRIM(cltxt2(ji)) /= '' ) WRITE(numout,*) TRIM(cltxt2(ji)) ! control print of domain size217 ! END DO218 278 ! 219 279 WRITE(numout,cform_aaa) ! Flag AAAAAAA 220 280 ! 221 281 ENDIF 222 ! open /dev/null file to be able to supress output write easily 223 ! CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 224 ! 225 ! ! Domain decomposition 226 CALL mpp_init ! MPP 282 ! 283 IF(lwm) WRITE( numond, namctl ) 284 ! 285 ! !-----------------------------------------! 286 ! ! mpp parameters and domain decomposition ! 287 ! !-----------------------------------------! 288 CALL mpp_init 289 CALL halo_mng_init() 290 ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 227 291 228 292 ! IF( Agrif_Root() ) THEN … … 268 332 ! 269 333 IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file 270 IF( numnam_ref /= -1 ) CLOSE( numnam_ref ) ! oce reference namelist271 IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist272 334 IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist 273 335 IF( numout /= 6 ) CLOSE( numout ) ! standard model output file … … 299 361 END SUBROUTINE nemo_alloc 300 362 363 SUBROUTINE nemo_set_cfctl(sn_cfctl, setto ) 364 !!---------------------------------------------------------------------- 365 !! *** ROUTINE nemo_set_cfctl *** 366 !! 367 !! ** Purpose : Set elements of the output control structure to setto. 368 !! 369 !! ** Method : Note this routine can be used to switch on/off some 370 !! types of output for selected areas. 371 !!---------------------------------------------------------------------- 372 TYPE(sn_ctl), INTENT(inout) :: sn_cfctl 373 LOGICAL , INTENT(in ) :: setto 374 !!---------------------------------------------------------------------- 375 sn_cfctl%l_runstat = setto 376 sn_cfctl%l_trcstat = setto 377 sn_cfctl%l_oceout = setto 378 sn_cfctl%l_layout = setto 379 sn_cfctl%l_prtctl = setto 380 sn_cfctl%l_prttrc = setto 381 sn_cfctl%l_oasout = setto 382 END SUBROUTINE nemo_set_cfctl 301 383 302 384 SUBROUTINE nemo_partition( num_pes ) … … 412 494 END SUBROUTINE factorise 413 495 414 415 SUBROUTINE nemo_northcomms416 !!----------------------------------------------------------------------417 !! *** ROUTINE nemo_northcomms ***418 !! ** Purpose : Setup for north fold exchanges with explicit419 !! point-to-point messaging420 !!421 !! ** Method : Initialization of the northern neighbours lists.422 !!----------------------------------------------------------------------423 !! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE)424 !! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)425 !!----------------------------------------------------------------------426 INTEGER :: sxM, dxM, sxT, dxT, jn427 INTEGER :: njmppmax428 !!----------------------------------------------------------------------429 !430 njmppmax = MAXVAL( njmppt )431 !432 !initializes the north-fold communication variables433 isendto(:) = 0434 nsndto = 0435 !436 !if I am a process in the north437 IF ( njmpp == njmppmax ) THEN438 !sxM is the first point (in the global domain) needed to compute the439 !north-fold for the current process440 sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1441 !dxM is the last point (in the global domain) needed to compute the442 !north-fold for the current process443 dxM = jpiglo - nimppt(narea) + 2444 445 !loop over the other north-fold processes to find the processes446 !managing the points belonging to the sxT-dxT range447 448 DO jn = 1, jpni449 !sxT is the first point (in the global domain) of the jn450 !process451 sxT = nfiimpp(jn, jpnj)452 !dxT is the last point (in the global domain) of the jn453 !process454 dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1455 IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN456 nsndto = nsndto + 1457 isendto(nsndto) = jn458 ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN459 nsndto = nsndto + 1460 isendto(nsndto) = jn461 ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN462 nsndto = nsndto + 1463 isendto(nsndto) = jn464 END IF465 END DO466 nfsloop = 1467 nfeloop = nlci468 DO jn = 2,jpni-1469 IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN470 IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN471 nfsloop = nldi472 ENDIF473 IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN474 nfeloop = nlei475 ENDIF476 ENDIF477 END DO478 479 ENDIF480 #if defined key_mpp_mpi481 l_north_nogather = .TRUE.482 #endif483 END SUBROUTINE nemo_northcomms484 485 486 496 !!====================================================================== 487 497 END MODULE nemogcm -
utils/tools/DOMAINcfg/src/par_kind.f90
r9598 r14623 24 24 INTEGER, PUBLIC, PARAMETER :: sp = SELECTED_REAL_KIND( 6, 37) !: single precision (real 4) 25 25 INTEGER, PUBLIC, PARAMETER :: dp = SELECTED_REAL_KIND(12,307) !: double precision (real 8) 26 # if defined key_single 27 INTEGER, PUBLIC, PARAMETER :: wp = sp !: working precision 28 # else 26 29 INTEGER, PUBLIC, PARAMETER :: wp = dp !: working precision 30 # endif 27 31 28 32 ! !!** Integer ** … … 31 35 32 36 ! !!** Integer ** 33 INTEGER, PUBLIC, PARAMETER :: lc = 256 !: Lenght of Character strings 37 INTEGER, PUBLIC, PARAMETER :: lc = 256 !: Lenght of Character strings 38 INTEGER, PUBLIC, PARAMETER :: lca = 400 !: Lenght of Character arrays 34 39 35 40 !!---------------------------------------------------------------------- 36 !! NEMO /OCE 4.0, NEMO Consortium (2018)37 !! $Id: par_kind.F90 2528 2010-12-27 17:33:53Z rblod$38 !! Software governed by the CeCILL licen ce (./LICENSE)41 !! NEMO 3.3 , NEMO Consortium (2018) 42 !! $Id: par_kind.F90 13226 2020-07-02 14:24:31Z orioltp $ 43 !! Software governed by the CeCILL license (see ./LICENSE) 39 44 !!---------------------------------------------------------------------- 40 45 END MODULE par_kind -
utils/tools/DOMAINcfg/src/par_oce.f90
r14199 r14623 28 28 !! namcfg namelist parameters 29 29 !!---------------------------------------------------------------------- 30 LOGICAL :: ln_read_cfg = .FALSE.!: (=T) read the domain configuration file or (=F) not30 LOGICAL :: ln_read_cfg !: (=T) read the domain configuration file or (=F) not 31 31 CHARACTER(lc) :: cn_domcfg !: filename the configuration file to be read 32 32 LOGICAL :: ln_write_cfg !: (=T) create the domain configuration file … … 44 44 !! Domain Matrix size 45 45 !!--------------------------------------------------------------------- 46 47 ! time dimension 48 INTEGER, PUBLIC, PARAMETER :: jpt = 3 !: time dimension 49 46 50 ! global domain size !!! * total computational domain * 47 51 INTEGER :: jpiglo !: 1st dimension of global domain --> i-direction … … 85 89 INTEGER, PUBLIC, PARAMETER :: jpr2di = 0 !: number of columns for extra outer halo 86 90 INTEGER, PUBLIC, PARAMETER :: jpr2dj = 0 !: number of rows for extra outer halo 87 INTEGER, PUBLIC, PARAMETER :: nn_hls = 1 !: halo width (applies to both rows and columns)88 91 92 ! halo with and starting/inding DO-loop indices 93 INTEGER, PUBLIC :: nn_hls !: halo width (applies to both rows and columns) 94 INTEGER, PUBLIC :: Nis0, Nis1, Nis1nxt2, Nis2 !: start I-index (_0: without halo, _1 or _2: with 1 or 2 halos) 95 INTEGER, PUBLIC :: Nie0, Nie1, Nie1nxt2, Nie2 !: end I-index (_0: without halo, _1 or _2: with 1 or 2 halos) 96 INTEGER, PUBLIC :: Njs0, Njs1, Njs1nxt2, Njs2 !: start J-index (_0: without halo, _1 or _2: with 1 or 2 halos) 97 INTEGER, PUBLIC :: Nje0, Nje1, Nje1nxt2, Nje2 !: end J-index (_0: without halo, _1 or _2: with 1 or 2 halos) 98 INTEGER, PUBLIC :: Ni_0, Nj_0, Ni_1, Nj_1, Ni_2, Nj_2 !: domain size (_0: without halo, _1 or _2: with 1 or 2 halos) 99 INTEGER, PUBLIC :: Ni0glo, Nj0glo 100 89 101 !!---------------------------------------------------------------------- 90 102 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
utils/tools/DOMAINcfg/src/stringop.f90
r6951 r14623 1 1 MODULE stringop 2 !$AGRIF_DO_NOT_TREAT 2 3 !- 3 4 !$Id: stringop.f90 2281 2010-10-15 14:21:13Z smasson $ … … 183 184 !=== 184 185 !------------------ 186 !$AGRIF_END_DO_NOT_TREAT 185 187 END MODULE stringop
Note: See TracChangeset
for help on using the changeset viewer.
