Changeset 13228
- Timestamp:
- 2020-07-02T16:41:07+02:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3
- Files:
-
- 123 edited
- 4 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ABL/ablmod.F90
r13219 r13228 529 529 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 530 530 ! 531 CALL lbc_lnk_multi( 'ablmod', u_abl(:,:,:,nt_a ), 'T', -1. , v_abl(:,:,:,nt_a) , 'T', -1.)532 CALL lbc_lnk_multi( 'ablmod', tq_abl(:,:,:,nt_a,jp_ta), 'T', 1., tq_abl(:,:,:,nt_a,jp_qa), 'T', 1., kfillmode = jpfillnothing ) ! ++++ this should not be needed...531 CALL lbc_lnk_multi( 'ablmod', u_abl(:,:,:,nt_a ), 'T', -1._wp, v_abl(:,:,:,nt_a) , 'T', -1._wp ) 532 CALL lbc_lnk_multi( 'ablmod', tq_abl(:,:,:,nt_a,jp_ta), 'T', 1._wp , tq_abl(:,:,:,nt_a,jp_qa), 'T', 1._wp , kfillmode = jpfillnothing ) ! ++++ this should not be needed... 533 533 ! 534 534 #if defined key_iomput … … 594 594 END_2D 595 595 ! 596 CALL lbc_lnk_multi( 'ablmod', zwnd_i(:,:) , 'T', -1. , zwnd_j(:,:) , 'T', -1.)596 CALL lbc_lnk_multi( 'ablmod', zwnd_i(:,:) , 'T', -1.0_wp, zwnd_j(:,:) , 'T', -1.0_wp ) 597 597 ! 598 598 ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked) … … 619 619 END_2D 620 620 ! 621 CALL lbc_lnk_multi( 'ablmod', ptaui(:,:), 'U', -1. , ptauj(:,:), 'V', -1.)621 CALL lbc_lnk_multi( 'ablmod', ptaui(:,:), 'U', -1.0_wp, ptauj(:,:), 'V', -1.0_wp ) 622 622 623 623 CALL iom_put( "taum_oce", ptaum ) … … 639 639 & * ( 0.5_wp * ( v_abl(ji,jj+1,2,nt_a) + v_abl(ji,jj,2,nt_a) ) - pssv_ice(ji,jj) ) 640 640 END_2D 641 CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1. , ptauj_ice, 'V', -1.)641 CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1.0_wp, ptauj_ice, 'V', -1.0_wp ) 642 642 ! 643 643 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=ptaui_ice , clinfo1=' abl_stp: putaui : ' & … … 658 658 & * ( zztmp2 - pssv_ice(ji,jj) ) 659 659 END_2D 660 CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1. , ptauj_ice, 'V', -1.)660 CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1.0_wp, ptauj_ice,'V', -1.0_wp ) 661 661 ! 662 662 IF(sn_cfctl%l_prtctl) THEN … … 865 865 ! Optional : could add pblh smoothing if pblh is noisy horizontally ... 866 866 IF(ln_smth_pblh) THEN 867 CALL lbc_lnk( 'ablmod', pblh, 'T', 1. ) !, kfillmode = jpfillnothing)867 CALL lbc_lnk( 'ablmod', pblh, 'T', 1.0_wp) !, kfillmode = jpfillnothing) 868 868 CALL smooth_pblh( pblh, msk_abl ) 869 CALL lbc_lnk( 'ablmod', pblh, 'T', 1. ) !, kfillmode = jpfillnothing)869 CALL lbc_lnk( 'ablmod', pblh, 'T', 1.0_wp) !, kfillmode = jpfillnothing) 870 870 ENDIF 871 871 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< … … 958 958 DO ji = 1, jpi 959 959 zbuoy = MAX( zbn2(ji, jj, jk), rsmall ) 960 zcff = 2. *SQRT(tke_abl( ji, jj, jk, nt_a )) / ( rn_Rod*zsh2(ji,jk) &961 & + SQRT( rn_Rod*rn_Rod*zsh2(ji,jk)*zsh2(ji,jk)+2.*zbuoy ) )960 zcff = 2.0_wp*SQRT(tke_abl( ji, jj, jk, nt_a )) / ( rn_Rod*zsh2(ji,jk) & 961 & + SQRT(rn_Rod*rn_Rod*zsh2(ji,jk)*zsh2(ji,jk)+2.0_wp*zbuoy ) ) 962 962 mxlm_abl( ji, jj, jk ) = MAX( mxl_min, zcff ) 963 963 END DO -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icecor.F90
r12724 r13228 114 114 ENDIF 115 115 END_2D 116 CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1. , v_ice, 'V', -1.)116 CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp ) 117 117 ENDIF 118 118 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icedyn.F90
r12377 r13228 129 129 zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. ) 130 130 zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. ) 131 u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1. , zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1)132 v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1. , zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1)131 u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1.0_wp, zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 132 v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1.0_wp, zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 133 133 END_2D 134 134 ! --- … … 159 159 & + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj) 160 160 END_2D 161 CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1. )161 CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1.0_wp ) 162 162 ! output 163 163 CALL iom_put( 'icediv' , zdivu_i ) -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icedyn_adv_pra.F90
r12724 r13228 117 117 END_2D 118 118 END DO 119 CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1. , zhs_max, 'T', 1., zhip_max, 'T', 1.)119 CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1.0_wp, zhs_max, 'T', 1.0_wp, zhip_max, 'T', 1.0_wp ) 120 120 ! 121 121 ! --- If ice drift is too fast, use subtime steps for advection (CFL test for stability) --- ! … … 254 254 & - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 255 255 END_2D 256 CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T', 1. )256 CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T', 1.0_wp ) 257 257 ! 258 258 ! --- Ensure non-negative fields --- ! … … 425 425 426 426 !-- Lateral boundary conditions 427 CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T', 1. , ps0 , 'T', 1.&428 & , psx , 'T', -1. , psy , 'T', -1.& ! caution gradient ==> the sign changes429 & , psxx , 'T', 1. , psyy, 'T', 1. , psxy, 'T', 1.)427 CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T', 1.0_wp, ps0 , 'T', 1.0_wp & 428 & , psx , 'T', -1.0_wp, psy , 'T', -1.0_wp & ! caution gradient ==> the sign changes 429 & , psxx , 'T', 1.0_wp, psyy, 'T', 1.0_wp , psxy, 'T', 1.0_wp ) 430 430 ! 431 431 END SUBROUTINE adv_x … … 584 584 585 585 !-- Lateral boundary conditions 586 CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T', 1. , ps0 , 'T', 1.&587 & , psx , 'T', -1. , psy , 'T', -1.& ! caution gradient ==> the sign changes588 & , psxx , 'T', 1. , psyy, 'T', 1. , psxy, 'T', 1.)586 CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T', 1.0_wp, ps0 , 'T', 1.0_wp & 587 & , psx , 'T', -1.0_wp, psy , 'T', -1.0_wp & ! caution gradient ==> the sign changes 588 & , psxx , 'T', 1.0_wp, psyy, 'T', 1.0_wp , psxy, 'T', 1.0_wp ) 589 589 ! 590 590 END SUBROUTINE adv_y -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icedyn_adv_umx.F90
r12724 r13228 122 122 END_2D 123 123 END DO 124 CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1. , zhs_max, 'T', 1., zhip_max, 'T', 1.)124 CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1.0_wp, zhs_max, 'T', 1.0_wp, zhip_max, 'T', 1.0_wp ) 125 125 ! 126 126 ! … … 336 336 & - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 337 337 END_2D 338 CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T', 1. )338 CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T', 1.0_wp ) 339 339 ! 340 340 ! … … 469 469 END_2D 470 470 END DO 471 CALL lbc_lnk( 'icedyn_adv_umx', zt_ups, 'T', 1. )471 CALL lbc_lnk( 'icedyn_adv_umx', zt_ups, 'T', 1.0_wp ) 472 472 ! 473 473 IF ( np_limiter == 1 ) THEN … … 500 500 END_2D 501 501 END DO 502 CALL lbc_lnk( 'icedyn_adv_umx', ptc, 'T', 1. )502 CALL lbc_lnk( 'icedyn_adv_umx', ptc, 'T', 1.0_wp ) 503 503 ! 504 504 END SUBROUTINE adv_umx … … 552 552 END_2D 553 553 END DO 554 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. )554 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) 555 555 ! 556 556 DO jl = 1, jpl !-- flux in y-direction … … 576 576 END_2D 577 577 END DO 578 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. )578 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) 579 579 ! 580 580 DO jl = 1, jpl !-- flux in x-direction … … 598 598 END_2D 599 599 END DO 600 CALL lbc_lnk( 'icedyn_adv_umx', pt_ups, 'T', 1. )600 CALL lbc_lnk( 'icedyn_adv_umx', pt_ups, 'T', 1.0_wp ) 601 601 602 602 END SUBROUTINE upstream … … 660 660 END_2D 661 661 END DO 662 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. )662 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) 663 663 664 664 DO jl = 1, jpl !-- flux in y-direction … … 686 686 END_2D 687 687 END DO 688 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. )688 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) 689 689 ! 690 690 DO jl = 1, jpl !-- flux in x-direction … … 744 744 END_2D 745 745 END DO 746 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. )746 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) 747 747 ! 748 748 ! !-- ultimate interpolation of pt at v-point --! … … 771 771 END_2D 772 772 END DO 773 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. )773 CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) 774 774 ! 775 775 ! !-- ultimate interpolation of pt at u-point --! … … 824 824 END DO 825 825 END DO 826 CALL lbc_lnk( 'icedyn_adv_umx', ztu2, 'T', 1. )826 CALL lbc_lnk( 'icedyn_adv_umx', ztu2, 'T', 1.0_wp ) 827 827 ! 828 828 ! !-- BiLaplacian in i-direction --! … … 838 838 END DO 839 839 END DO 840 CALL lbc_lnk( 'icedyn_adv_umx', ztu4, 'T', 1. )840 CALL lbc_lnk( 'icedyn_adv_umx', ztu4, 'T', 1.0_wp ) 841 841 ! 842 842 ! … … 964 964 END_2D 965 965 END DO 966 CALL lbc_lnk( 'icedyn_adv_umx', ztv2, 'T', 1. )966 CALL lbc_lnk( 'icedyn_adv_umx', ztv2, 'T', 1.0_wp ) 967 967 ! 968 968 ! !-- BiLaplacian in j-direction --! … … 975 975 END_2D 976 976 END DO 977 CALL lbc_lnk( 'icedyn_adv_umx', ztv4, 'T', 1. )977 CALL lbc_lnk( 'icedyn_adv_umx', ztv4, 'T', 1.0_wp ) 978 978 ! 979 979 ! … … 1114 1114 END_2D 1115 1115 END DO 1116 CALL lbc_lnk_multi( 'icedyn_adv_umx', zti_ups, 'T', 1. , ztj_ups, 'T', 1.)1116 CALL lbc_lnk_multi( 'icedyn_adv_umx', zti_ups, 'T', 1.0_wp, ztj_ups, 'T', 1.0_wp ) 1117 1117 1118 1118 DO jl = 1, jpl … … 1136 1136 END_2D 1137 1137 END DO 1138 CALL lbc_lnk_multi( 'icedyn_adv_umx', pfu_ho, 'U', -1. , pfv_ho, 'V', -1.) ! lateral boundary cond.1138 CALL lbc_lnk_multi( 'icedyn_adv_umx', pfu_ho, 'U', -1.0_wp, pfv_ho, 'V', -1.0_wp ) ! lateral boundary cond. 1139 1139 1140 1140 ENDIF … … 1193 1193 END_2D 1194 1194 END DO 1195 CALL lbc_lnk_multi( 'icedyn_adv_umx', zbetup, 'T', 1. , zbetdo, 'T', 1.) ! lateral boundary cond. (unchanged sign)1195 CALL lbc_lnk_multi( 'icedyn_adv_umx', zbetup, 'T', 1.0_wp, zbetdo, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign) 1196 1196 1197 1197 … … 1248 1248 END_2D 1249 1249 END DO 1250 CALL lbc_lnk( 'icedyn_adv_umx', zslpx, 'U', -1. ) ! lateral boundary cond.1250 CALL lbc_lnk( 'icedyn_adv_umx', zslpx, 'U', -1.0_wp) ! lateral boundary cond. 1251 1251 1252 1252 DO jl = 1, jpl … … 1312 1312 END_2D 1313 1313 END DO 1314 CALL lbc_lnk( 'icedyn_adv_umx', pfu_ho, 'U', -1. ) ! lateral boundary cond.1314 CALL lbc_lnk( 'icedyn_adv_umx', pfu_ho, 'U', -1.0_wp) ! lateral boundary cond. 1315 1315 ! 1316 1316 END SUBROUTINE limiter_x … … 1339 1339 END_2D 1340 1340 END DO 1341 CALL lbc_lnk( 'icedyn_adv_umx', zslpy, 'V', -1. ) ! lateral boundary cond.1341 CALL lbc_lnk( 'icedyn_adv_umx', zslpy, 'V', -1.0_wp) ! lateral boundary cond. 1342 1342 1343 1343 DO jl = 1, jpl … … 1404 1404 END_2D 1405 1405 END DO 1406 CALL lbc_lnk( 'icedyn_adv_umx', pfv_ho, 'V', -1. ) ! lateral boundary cond.1406 CALL lbc_lnk( 'icedyn_adv_umx', pfv_ho, 'V', -1.0_wp) ! lateral boundary cond. 1407 1407 ! 1408 1408 END SUBROUTINE limiter_y -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icedyn_rdgrft.F90
r12724 r13228 300 300 301 301 ! ! Ice thickness needed for rafting 302 ! In single precision there were floating point invalids due a sqrt of zhi which happens to have negative values 303 ! To solve that an extra check about the value of pv_i was added. 304 ! Although adding this condition is safe, the double definition (one for single other for double) has been kept to preserve the results of the sette test. 305 #if defined key_single 306 307 WHERE( pa_i(1:npti,:) > epsi10 .and. pv_i(1:npti,:) > epsi10 ) ; zhi(1:npti,:) = pv_i(1:npti,:) / pa_i(1:npti,:) 308 #else 302 309 WHERE( pa_i(1:npti,:) > epsi10 ) ; zhi(1:npti,:) = pv_i(1:npti,:) / pa_i(1:npti,:) 310 #endif 303 311 ELSEWHERE ; zhi(1:npti,:) = 0._wp 304 312 END WHERE … … 780 788 strength(ji,jj) = zworka(ji,jj) 781 789 END_2D 782 CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1. )790 CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1.0_wp ) 783 791 ! 784 792 CASE( 2 ) !--- Temporal smoothing … … 799 807 ENDIF 800 808 END_2D 801 CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1. )809 CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1.0_wp ) 802 810 ! 803 811 END SELECT -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icedyn_rhg_evp.F90
r12731 r13228 300 300 301 301 END_2D 302 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1. , zdt_m, 'T', 1.)302 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp ) 303 303 ! 304 304 ! !== Landfast ice parameterization ==! … … 319 319 tau_icebfr(ji,jj) = - rn_icebfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 320 320 END_2D 321 CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1. )321 CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1.0_wp ) 322 322 ! 323 323 ELSE !-- no landfast … … 353 353 354 354 END_2D 355 CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1. )355 CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1.0_wp ) 356 356 357 357 DO_2D_01_01 … … 395 395 396 396 END_2D 397 CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1. )397 CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1.0_wp ) 398 398 399 399 DO_2D_10_10 … … 484 484 ENDIF 485 485 END_2D 486 CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. )486 CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1.0_wp ) 487 487 ! 488 488 #if defined key_agrif … … 533 533 ENDIF 534 534 END_2D 535 CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. )535 CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp ) 536 536 ! 537 537 #if defined key_agrif … … 584 584 ENDIF 585 585 END_2D 586 CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. )586 CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp ) 587 587 ! 588 588 #if defined key_agrif … … 633 633 ENDIF 634 634 END_2D 635 CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. )635 CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1.0_wp ) 636 636 ! 637 637 #if defined key_agrif … … 694 694 695 695 END_2D 696 CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1. , pdivu_i, 'T', 1., pdelta_i, 'T', 1.)696 CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1.0_wp, pdivu_i, 'T', 1.0_wp, pdelta_i, 'T', 1.0_wp ) 697 697 698 698 ! --- Store the stress tensor for the next time step --- ! 699 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zs1, 'T', 1. , zs2, 'T', 1., zs12, 'F', 1.)699 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zs1, 'T', 1.0_wp, zs2, 'T', 1.0_wp, zs12, 'F', 1.0_wp ) 700 700 pstress1_i (:,:) = zs1 (:,:) 701 701 pstress2_i (:,:) = zs2 (:,:) … … 714 714 & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN 715 715 ! 716 CALL lbc_lnk_multi( 'icedyn_rhg_evp', ztaux_oi, 'U', -1. , ztauy_oi, 'V', -1., ztaux_ai, 'U', -1., ztauy_ai, 'V', -1., &717 & ztaux_bi, 'U', -1. , ztauy_bi, 'V', -1.)716 CALL lbc_lnk_multi( 'icedyn_rhg_evp', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, ztaux_ai, 'U', -1.0_wp, ztauy_ai, 'V', -1.0_wp, & 717 & ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 718 718 ! 719 719 CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) … … 752 752 zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) 753 753 END_2D 754 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1. , zsig2, 'T', 1., zsig3, 'T', 1.)754 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1.0_wp, zsig2, 'T', 1.0_wp, zsig3, 'T', 1.0_wp ) 755 755 ! 756 756 CALL iom_put( 'isig1' , zsig1 ) … … 769 769 & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN 770 770 ! 771 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zspgU, 'U', -1. , zspgV, 'V', -1., &772 & zCorU, 'U', -1. , zCorV, 'V', -1., zfU, 'U', -1., zfV, 'V', -1.)771 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, & 772 & zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp ) 773 773 774 774 CALL iom_put( 'dssh_dx' , zspgU * zmsk00 ) ! Sea-surface tilt term in force balance (x) … … 802 802 END_2D 803 803 804 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1. , zdiag_ymtrp_ice, 'V', -1., &805 & zdiag_xmtrp_snw, 'U', -1. , zdiag_ymtrp_snw, 'V', -1., &806 & zdiag_xatrp , 'U', -1. , zdiag_yatrp , 'V', -1.)804 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, & 805 & zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, & 806 & zdiag_xatrp , 'U', -1.0_wp, zdiag_yatrp , 'V', -1.0_wp ) 807 807 808 808 CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s) -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/iceitd.F90
r12377 r13228 148 148 ! Note: hn(t+1) must not be too close to either HR or HL otherwise a division by nearly 0 is possible 149 149 ! in itd_glinear in the case (HR-HL) = 3(Hice - HL) or = 3(HR - Hice) 150 # if defined key_single 151 IF( a_i_2d(ji,jl ) > epsi10 .AND. h_i_2d(ji,jl ) > ( zhbnew(ji,jl) - epsi06 ) ) nptidx(ji) = 0 152 IF( a_i_2d(ji,jl+1) > epsi10 .AND. h_i_2d(ji,jl+1) < ( zhbnew(ji,jl) + epsi06 ) ) nptidx(ji) = 0 153 # else 150 154 IF( a_i_2d(ji,jl ) > epsi10 .AND. h_i_2d(ji,jl ) > ( zhbnew(ji,jl) - epsi10 ) ) nptidx(ji) = 0 151 155 IF( a_i_2d(ji,jl+1) > epsi10 .AND. h_i_2d(ji,jl+1) < ( zhbnew(ji,jl) + epsi10 ) ) nptidx(ji) = 0 156 # endif 152 157 ! 153 158 ! 2) Hn-1 < Hn* < Hn+1 … … 170 175 ! h1(t) must not be too close to either HR or HL otherwise a division by nearly 0 is possible 171 176 ! in itd_glinear in the case (HR-HL) = 3(Hice - HL) or = 3(HR - Hice) 177 # if defined key_single 178 IF( h_ib_2d(ji,1) < ( hi_max(0) + epsi06 ) ) nptidx(ji) = 0 179 IF( h_ib_2d(ji,1) > ( hi_max(1) - epsi06 ) ) nptidx(ji) = 0 180 # else 172 181 IF( h_ib_2d(ji,1) < ( hi_max(0) + epsi10 ) ) nptidx(ji) = 0 173 182 IF( h_ib_2d(ji,1) > ( hi_max(1) - epsi10 ) ) nptidx(ji) = 0 183 # endif 174 184 END DO 175 185 ! … … 538 548 ! 4) Update ice thickness and temperature 539 549 !------------------------------------------------------------------------------- 550 # if defined key_single 551 WHERE( a_i_2d(1:npti,:) >= epsi06 ) 552 # else 540 553 WHERE( a_i_2d(1:npti,:) >= epsi20 ) 554 # endif 541 555 h_i_2d (1:npti,:) = v_i_2d(1:npti,:) / a_i_2d(1:npti,:) 542 556 t_su_2d(1:npti,:) = zaTsfn(1:npti,:) / a_i_2d(1:npti,:) -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icesbc.F90
r12377 r13228 86 86 vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 87 87 END_2D 88 CALL lbc_lnk_multi( 'icesbc', utau_ice, 'U', -1. , vtau_ice, 'V', -1.)88 CALL lbc_lnk_multi( 'icesbc', utau_ice, 'U', -1.0_wp, vtau_ice, 'V', -1.0_wp ) 89 89 ENDIF 90 90 ! -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icethd.F90
r12724 r13228 121 121 END_2D 122 122 ENDIF 123 CALL lbc_lnk( 'icethd', zfric, 'T', 1. )123 CALL lbc_lnk( 'icethd', zfric, 'T', 1.0_wp ) 124 124 ! 125 125 !--------------------------------------------------------------------! … … 218 218 CALL ice_thd_dh ! Ice-Snow thickness 219 219 CALL ice_thd_pnd ! Melt ponds formation 220 CALL ice_thd_ent( e_i_1d(1:npti,:) ) ! Ice enthalpy remapping220 CALL ice_thd_ent( e_i_1d(1:npti,:), .true. ) ! Ice enthalpy remapping 221 221 ENDIF 222 222 CALL ice_thd_sal( ln_icedS ) ! --- Ice salinity --- ! -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icethd_dh.F90
r12724 r13228 186 186 ! Snow precipitation 187 187 !------------------- 188 CALL ice_thd_snwblow( 1. - at_i_1d(1:npti), zsnw(1:npti) ) ! snow distribution over ice after wind blowing188 CALL ice_thd_snwblow( 1.0_wp - at_i_1d(1:npti), zsnw(1:npti) ) ! snow distribution over ice after wind blowing 189 189 190 190 zdeltah(1:npti,:) = 0._wp … … 442 442 443 443 zEi = rcpi * ( zt_i_new - (ztmelts+rt0) ) & ! Specific enthalpy of forming ice (J/kg, <0) 444 & - rLfus * ( 1.0 - ztmelts / ( zt_i_new - rt0) ) + rcp * ztmelts444 & - rLfus * ( 1.0 - ztmelts / ( MIN( zt_i_new - rt0, -epsi10 ) ) ) + rcp * ztmelts 445 445 446 446 zEw = rcp * ( t_bo_1d(ji) - rt0 ) ! Specific enthalpy of seawater (J/kg, < 0) -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icethd_do.F90
r12724 r13228 191 191 END_2D 192 192 ! 193 CALL lbc_lnk_multi( 'icethd_do', zvrel, 'T', 1. , ht_i_new, 'T', 1.)193 CALL lbc_lnk_multi( 'icethd_do', zvrel, 'T', 1.0_wp, ht_i_new, 'T', 1.0_wp ) 194 194 195 195 ENDIF … … 385 385 END DO 386 386 ! --- Ice enthalpy remapping --- ! 387 CALL ice_thd_ent( ze_i_2d(1:npti,:,jl) )387 CALL ice_thd_ent( ze_i_2d(1:npti,:,jl), .false. ) 388 388 END DO 389 389 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icethd_ent.F90
r12724 r13228 38 38 CONTAINS 39 39 40 SUBROUTINE ice_thd_ent( qnew )40 SUBROUTINE ice_thd_ent( qnew, compute_hfx_err ) 41 41 !!------------------------------------------------------------------- 42 42 !! *** ROUTINE ice_thd_ent *** … … 64 64 !!------------------------------------------------------------------- 65 65 REAL(wp), DIMENSION(:,:), INTENT(inout) :: qnew ! new enthlapies (J.m-3, remapped) 66 LOGICAL, INTENT(in) :: compute_hfx_err ! determines whether to compute diag. 67 ! error or not 66 68 ! 67 69 INTEGER :: ji ! dummy loop indices … … 128 130 ! comment: if input h_i_old and eh_i_old are already multiplied by a_i (as in icethd_do), 129 131 ! then we should not (* a_i) again but not important since this is just to check that remap error is ~0 130 DO ji = 1, npti 131 hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_Dt_ice * & 132 & ( SUM( qnew(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_i_old(ji,0:nlay_i+1) ) ) 133 END DO 134 132 IF( compute_hfx_err ) THEN 133 DO ji = 1, npti 134 hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_Dt_ice * & 135 & ( SUM( qnew(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_i_old(ji,0:nlay_i+1) ) ) 136 END DO 137 END IF 138 135 139 END SUBROUTINE ice_thd_ent 136 140 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/iceupdate.F90
r12724 r13228 342 342 tmod_io(ji,jj) = zrhoco * SQRT( zmodt ) ! rhoco * |U_ice-U_oce| at T-point 343 343 END_2D 344 CALL lbc_lnk_multi( 'iceupdate', taum, 'T', 1. , tmod_io, 'T', 1.)344 CALL lbc_lnk_multi( 'iceupdate', taum, 'T', 1.0_wp, tmod_io, 'T', 1.0_wp ) 345 345 ! 346 346 utau_oce(:,:) = utau(:,:) !* save the air-ocean stresses at ice time-step … … 364 364 vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice 365 365 END_2D 366 CALL lbc_lnk_multi( 'iceupdate', utau, 'U', -1. , vtau, 'V', -1.) ! lateral boundary condition366 CALL lbc_lnk_multi( 'iceupdate', utau, 'U', -1.0_wp, vtau, 'V', -1.0_wp ) ! lateral boundary condition 367 367 ! 368 368 IF( ln_timing ) CALL timing_stop('ice_update_tau') -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icevar.F90
r12724 r13228 635 635 !!------------------------------------------------------------------- 636 636 ! 637 WHERE( pa_i (1:npti,:) < 0._wp .AND. pa_i (1:npti,:) > -epsi10 ) pa_i (1:npti,:) = 0._wp ! a_i must be >= 0 638 WHERE( pv_i (1:npti,:) < 0._wp .AND. pv_i (1:npti,:) > -epsi10 ) pv_i (1:npti,:) = 0._wp ! v_i must be >= 0 639 WHERE( pv_s (1:npti,:) < 0._wp .AND. pv_s (1:npti,:) > -epsi10 ) pv_s (1:npti,:) = 0._wp ! v_s must be >= 0 640 WHERE( psv_i(1:npti,:) < 0._wp .AND. psv_i(1:npti,:) > -epsi10 ) psv_i(1:npti,:) = 0._wp ! sv_i must be >= 0 641 WHERE( poa_i(1:npti,:) < 0._wp .AND. poa_i(1:npti,:) > -epsi10 ) poa_i(1:npti,:) = 0._wp ! oa_i must be >= 0 642 WHERE( pe_i (1:npti,:,:) < 0._wp .AND. pe_i (1:npti,:,:) > -epsi06 ) pe_i (1:npti,:,:) = 0._wp ! e_i must be >= 0 643 WHERE( pe_s (1:npti,:,:) < 0._wp .AND. pe_s (1:npti,:,:) > -epsi06 ) pe_s (1:npti,:,:) = 0._wp ! e_s must be >= 0 637 638 WHERE( pa_i (1:npti,:) < 0._wp ) pa_i (1:npti,:) = 0._wp ! a_i must be >= 0 639 WHERE( pv_i (1:npti,:) < 0._wp ) pv_i (1:npti,:) = 0._wp ! v_i must be >= 0 640 WHERE( pv_s (1:npti,:) < 0._wp ) pv_s (1:npti,:) = 0._wp ! v_s must be >= 0 641 WHERE( psv_i(1:npti,:) < 0._wp ) psv_i(1:npti,:) = 0._wp ! sv_i must be >= 0 642 WHERE( poa_i(1:npti,:) < 0._wp ) poa_i(1:npti,:) = 0._wp ! oa_i must be >= 0 643 WHERE( pe_i (1:npti,:,:) < 0._wp ) pe_i (1:npti,:,:) = 0._wp ! e_i must be >= 0 644 WHERE( pe_s (1:npti,:,:) < 0._wp ) pe_s (1:npti,:,:) = 0._wp ! e_s must be >= 0 644 645 IF( ln_pnd_H12 ) THEN 645 WHERE( pa_ip(1:npti,:) < 0._wp .AND. pa_ip(1:npti,:) > -epsi10) pa_ip(1:npti,:) = 0._wp ! a_ip must be >= 0646 WHERE( pv_ip(1:npti,:) < 0._wp .AND. pv_ip(1:npti,:) > -epsi10) pv_ip(1:npti,:) = 0._wp ! v_ip must be >= 0646 WHERE( pa_ip(1:npti,:) < 0._wp ) pa_ip(1:npti,:) = 0._wp ! a_ip must be >= 0 647 WHERE( pv_ip(1:npti,:) < 0._wp ) pv_ip(1:npti,:) = 0._wp ! v_ip must be >= 0 647 648 ENDIF 648 649 ! -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icewri.F90
r12724 r13228 135 135 z2d(ji,jj) = 0.5_wp * SQRT( z2da * z2da + z2db * z2db ) 136 136 END_2D 137 CALL lbc_lnk( 'icewri', z2d, 'T', 1. )137 CALL lbc_lnk( 'icewri', z2d, 'T', 1.0_wp ) 138 138 CALL iom_put( 'icevel', z2d ) 139 139 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/NST/agrif_oce_sponge.F90
r13219 r13228 295 295 fspv(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji ,jj+1) ) * ssvmask(ji,jj) 296 296 END_2D 297 CALL lbc_lnk( 'agrif_Sponge', fspu, 'U', 1. ) ! Lateral boundary conditions298 CALL lbc_lnk( 'agrif_Sponge', fspv, 'V', 1. )297 CALL lbc_lnk( 'agrif_Sponge', fspu, 'U', 1.0_wp ) ! Lateral boundary conditions 298 CALL lbc_lnk( 'agrif_Sponge', fspv, 'V', 1.0_wp ) 299 299 300 300 spongedoneT = .TRUE. … … 311 311 & * ssvmask(ji,jj) * ssvmask(ji,jj+1) 312 312 END_2D 313 CALL lbc_lnk( 'agrif_Sponge', fspt, 'T', 1. ) ! Lateral boundary conditions314 CALL lbc_lnk( 'agrif_Sponge', fspf, 'F', 1. )313 CALL lbc_lnk( 'agrif_Sponge', fspt, 'T', 1.0_wp ) ! Lateral boundary conditions 314 CALL lbc_lnk( 'agrif_Sponge', fspf, 'F', 1.0_wp ) 315 315 316 316 spongedoneU = .TRUE. … … 334 334 END_2D 335 335 ! 336 ztabramp(:,:) = REAL( mbkt_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'T', 1. )336 ztabramp(:,:) = REAL( mbkt_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'T', 1.0_wp ) 337 337 mbkt_parent(:,:) = NINT( ztabramp(:,:) ) 338 ztabramp(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'U', 1. )338 ztabramp(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'U', 1.0_wp ) 339 339 mbku_parent(:,:) = NINT( ztabramp(:,:) ) 340 ztabramp(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'V', 1. )340 ztabramp(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'V', 1.0_wp ) 341 341 mbkv_parent(:,:) = NINT( ztabramp(:,:) ) 342 342 #endif -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/NST/agrif_user.F90
r13219 r13228 271 271 ENDIF 272 272 ! 273 CALL lbc_lnk( 'Agrif_Init_Domain', hu0_parent, 'U', 1. )274 CALL lbc_lnk( 'Agrif_Init_Domain', hv0_parent, 'V', 1. )275 zk(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'U', 1.)273 CALL lbc_lnk( 'Agrif_Init_Domain', hu0_parent, 'U', 1.0_wp ) 274 CALL lbc_lnk( 'Agrif_Init_Domain', hv0_parent, 'V', 1.0_wp ) 275 zk(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk('Agrif_InitValues_cont', zk, 'U', 1.0_wp ) 276 276 mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) ; 277 zk(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1. )277 zk(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1.0_wp ) 278 278 mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 279 279 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ASM/asminc.F90
r12732 r13228 421 421 & / e3t(ji,jj,jk,Kmm) 422 422 END_2D 423 CALL lbc_lnk( 'asminc', zhdiv, 'T', 1. ) ! lateral boundary cond. (no sign change)423 CALL lbc_lnk( 'asminc', zhdiv, 'T', 1.0_wp ) ! lateral boundary cond. (no sign change) 424 424 ! 425 425 DO_2D_00_00 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/BDY/bdydyn2d.F90
r11536 r13228 102 102 END DO 103 103 IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction 104 CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1. , kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 )104 CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 105 105 END IF 106 106 IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction 107 CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1. , kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 )107 CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 108 108 END IF 109 109 ! … … 324 324 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 325 325 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 326 CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T', 1. , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )326 CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 327 327 END IF 328 328 END DO -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/BDY/bdydyn3d.F90
r12377 r13228 99 99 ! 100 100 IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction 101 CALL lbc_lnk( 'bdydyn2d', puu(:,:,:,Kaa), 'U', -1. , kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 )101 CALL lbc_lnk( 'bdydyn2d', puu(:,:,:,Kaa), 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 102 102 END IF 103 103 IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction 104 CALL lbc_lnk( 'bdydyn2d', pvv(:,:,:,Kaa), 'V', -1. , kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 )104 CALL lbc_lnk( 'bdydyn2d', pvv(:,:,:,Kaa), 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 105 105 END IF 106 106 END DO ! ir -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/BDY/bdyice.F90
r12724 r13228 94 94 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 95 95 ! exchange 3d arrays 96 CALL lbc_lnk_multi( 'bdyice', a_i , 'T', 1. , h_i , 'T', 1., h_s , 'T', 1., oa_i, 'T', 1.&97 & , a_ip, 'T', 1. , v_ip, 'T', 1., s_i , 'T', 1., t_su, 'T', 1.&98 & , v_i , 'T', 1. , v_s , 'T', 1., sv_i, 'T', 1.&96 CALL lbc_lnk_multi( 'bdyice', a_i , 'T', 1.0_wp, h_i , 'T', 1.0_wp, h_s , 'T', 1.0_wp, oa_i, 'T', 1.0_wp & 97 & , a_ip, 'T', 1.0_wp, v_ip, 'T', 1.0_wp, s_i , 'T', 1.0_wp, t_su, 'T', 1.0_wp & 98 & , v_i , 'T', 1.0_wp, v_s , 'T', 1.0_wp, sv_i, 'T', 1.0_wp & 99 99 & , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 100 100 ! exchange 4d arrays : third dimension = 1 and then third dimension = jpk 101 CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1. , e_s , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )102 CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1. , e_i , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )101 CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1.0_wp, e_s , 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 102 CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1.0_wp, e_i , 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 103 103 END IF 104 104 END DO ! ir … … 436 436 END DO 437 437 IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction 438 CALL lbc_lnk( 'bdyice', u_ice, 'U', -1. , kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 )438 CALL lbc_lnk( 'bdyice', u_ice, 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 439 439 END IF 440 440 CASE ( 'V' ) … … 450 450 END DO 451 451 IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction 452 CALL lbc_lnk( 'bdyice', v_ice, 'V', -1. , kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 )452 CALL lbc_lnk( 'bdyice', v_ice, 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 453 453 END IF 454 454 END SELECT -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/BDY/bdyini.F90
r13193 r13228 638 638 END DO 639 639 END DO 640 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. )640 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_wp ) 641 641 642 642 ! Read global 2D mask at T-points: bdytmask … … 654 654 END DO 655 655 END DO 656 CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1. , bdyvmask, 'V', 1. ) ! Lateral boundary cond.656 CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1.0_wp , bdyvmask, 'V', 1.0_wp ) ! Lateral boundary cond. 657 657 658 658 ! bdy masks are now set to zero on rim 0 points: … … 695 695 END DO 696 696 END DO 697 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. )697 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_wp ) 698 698 699 699 ! bdy masks are now set to zero on rim1 points: … … 871 871 ENDIF 872 872 SELECT CASE( igrd ) 873 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )874 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )875 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )873 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) 874 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) 875 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) 876 876 END SELECT 877 877 DO ib = ibeg, iend … … 919 919 ENDIF 920 920 SELECT CASE( igrd ) 921 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )922 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )923 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )921 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) 922 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) 923 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) 924 924 END SELECT 925 925 DO ib = ibeg, iend … … 1007 1007 END DO 1008 1008 SELECT CASE( igrd ) 1009 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )1010 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )1011 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )1009 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) 1010 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) 1011 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) 1012 1012 END SELECT 1013 1013 DO ib = ibeg, iend -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/BDY/bdylib.F90
r12724 r13228 249 249 !!$ zdy_centred = phib(iibm1jp1,ijbm1jp1) - phib(iibm1jm1,ijbm1jm1) 250 250 ! upstream differencing for tangential derivatives 251 zsign_ups = sign( 1. , zdt * zdy_centred )251 zsign_ups = sign( 1.0_wp, zdt * zdy_centred ) 252 252 zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) 253 253 zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2 … … 257 257 zrx = zdt * zdx / ( zex1 * znor2 ) 258 258 !!$ zrx = min(zrx,2.0_wp) 259 zout = sign( 1. , zrx )259 zout = sign( 1.0_wp, zrx ) 260 260 zout = 0.5*( zout + abs(zout) ) 261 261 zwgt = 2.*rn_Dt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) ) … … 266 266 & + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) 267 267 else !! full oblique radiation !! 268 zsign_ups = sign( 1. , zdt * zdy )268 zsign_ups = sign( 1.0_wp, zdt * zdy ) 269 269 zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) 270 270 zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2 … … 414 414 !!$ zdy_centred = phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1jm1,ijbm1jm1,jk) 415 415 ! upstream differencing for tangential derivatives 416 zsign_ups = sign( 1. , zdt * zdy_centred )416 zsign_ups = sign( 1.0_wp, zdt * zdy_centred ) 417 417 zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) 418 418 zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2 … … 423 423 zrx = zdt * zdx / ( zex1 * znor2 ) 424 424 !!$ zrx = min(zrx,2.0_wp) 425 zout = sign( 1. , zrx )425 zout = sign( 1.0_wp, zrx ) 426 426 zout = 0.5*( zout + abs(zout) ) 427 427 zwgt = 2.*rn_Dt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) ) … … 432 432 & + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) 433 433 else !! full oblique radiation !! 434 zsign_ups = sign( 1. , zdt * zdy )434 zsign_ups = sign( 1.0_wp, zdt * zdy ) 435 435 zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) 436 436 zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/BDY/bdytra.F90
r12377 r13228 100 100 END DO 101 101 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 102 CALL lbc_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T', 1. , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )102 CALL lbc_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 103 103 END IF 104 104 ! -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/CRS/crsdom.F90
r11536 r13228 86 86 zmask = 0.0 87 87 zmask = SUM( tmask(ijis:ijie,ij:je_2,jk) ) 88 IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0 88 IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0_wp 89 89 90 90 zmask = 0.0 91 91 zmask = SUM( vmask(ijis:ijie,je_2 ,jk) ) 92 IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0 92 IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0_wp 93 93 94 94 zmask = 0.0 95 95 zmask = SUM(umask(ijie,ij:je_2,jk)) 96 IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0 96 IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0_wp 97 97 98 98 fmask_crs(ji,je_2,jk) = fmask(ijie,2,jk) … … 108 108 zmask = 0.0 109 109 zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) 110 IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0 110 IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0_wp 111 111 112 112 zmask = 0.0 113 113 zmask = SUM( vmask(ijis:ijie,ijje ,jk) ) 114 IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0 114 IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0_wp 115 115 116 116 zmask = 0.0 117 117 zmask = SUM( umask(ijie ,ijjs:ijje,jk) ) 118 IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0 118 IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0_wp 119 119 120 120 fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk) … … 124 124 125 125 ! 126 CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 )127 CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 )128 CALL crs_lbc_lnk( umask_crs, 'U', 1.0 )129 CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 )126 CALL crs_lbc_lnk( tmask_crs, 'T', 1.0_wp ) 127 CALL crs_lbc_lnk( vmask_crs, 'V', 1.0_wp ) 128 CALL crs_lbc_lnk( umask_crs, 'U', 1.0_wp ) 129 CALL crs_lbc_lnk( fmask_crs, 'F', 1.0_wp ) 130 130 ! 131 131 END SUBROUTINE crs_dom_msk … … 206 206 207 207 ! Retroactively add back the boundary halo cells. 208 CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0 )209 CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 )208 CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0_wp ) 209 CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0_wp ) 210 210 211 211 ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd … … 296 296 ENDDO 297 297 298 CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0 , pfillval=1.0)299 CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0 , pfillval=1.0)298 CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) 299 CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) 300 300 301 301 END SUBROUTINE crs_dom_hgr … … 440 440 ENDDO 441 441 ! ! Retroactively add back the boundary halo cells. 442 CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0 )443 CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 )442 CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0_wp ) 443 CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0_wp ) 444 444 ! 445 445 ! … … 1748 1748 ENDDO 1749 1749 1750 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0 , pfillval=1.0)1751 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0 , pfillval=1.0)1750 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0_wp, pfillval=1.0_wp ) 1751 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) 1752 1752 ! 1753 1753 ! … … 1857 1857 ENDDO 1858 1858 1859 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0 , pfillval=1.0)1860 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0 , pfillval=1.0)1859 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0_wp, pfillval=1.0_wp ) 1860 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0_wp, pfillval=1.0_wp ) 1861 1861 1862 1862 END SUBROUTINE crs_dom_sfc … … 2246 2246 2247 2247 zmbk(:,:) = 0.0 2248 zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0 ) ; mbathy_crs(:,:) = NINT( zmbk(:,:) )2248 zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0_wp) ; mbathy_crs(:,:) = NINT( zmbk(:,:) ) 2249 2249 2250 2250 … … 2266 2266 ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 2267 2267 zmbk(:,:) = 1.e0; 2268 zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0 ) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 )2269 zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0 ) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 )2268 zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0_wp) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) 2269 zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0_wp) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) 2270 2270 ! 2271 2271 END SUBROUTINE crs_dom_bat -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/CRS/crsdomwri.F90
r12377 r13228 161 161 END DO 162 162 END DO 163 CALL crs_lbc_lnk( zdepu,'U', 1. ) ; CALL crs_lbc_lnk( zdepv,'V', 1.)163 CALL crs_lbc_lnk( zdepu,'U', 1.0_wp ) ; CALL crs_lbc_lnk( zdepv,'V', 1.0_wp ) 164 164 ! 165 165 CALL iom_rstput( 0, 0, inum, 'gdepu', zdepu, ktype = jp_r4 ) … … 222 222 ! 223 223 puniq(:,:) = ztstref(:,:) ! default definition 224 CALL crs_lbc_lnk( puniq,cdgrd, 1. ) ! apply boundary conditions224 CALL crs_lbc_lnk( puniq,cdgrd, 1.0_wp ) ! apply boundary conditions 225 225 lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed 226 226 ! -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/CRS/crsfld.F90
r12616 r13228 101 101 ! Temperature 102 102 zt(:,:,:) = ts(:,:,:,jp_tem,Kmm) ; zt_crs(:,:,:) = 0._wp 103 CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 )103 CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) 104 104 tsn_crs(:,:,:,jp_tem) = zt_crs(:,:,:) 105 105 … … 110 110 ! Salinity 111 111 zs(:,:,:) = ts(:,:,:,jp_sal,Kmm) ; zs_crs(:,:,:) = 0._wp 112 CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 )112 CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) 113 113 tsn_crs(:,:,:,jp_sal) = zt_crs(:,:,:) 114 114 … … 117 117 118 118 ! U-velocity 119 CALL crs_dom_ope( uu(:,:,:,Kmm), 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )119 CALL crs_dom_ope( uu(:,:,:,Kmm), 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) 120 120 ! 121 121 zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp … … 124 124 zs(ji,jj,jk) = uu(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) ) 125 125 END_3D 126 CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )127 CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )126 CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) 127 CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) 128 128 129 129 CALL iom_put( "uoce" , un_crs ) ! i-current … … 132 132 133 133 ! V-velocity 134 CALL crs_dom_ope( vv(:,:,:,Kmm), 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )134 CALL crs_dom_ope( vv(:,:,:,Kmm), 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) 135 135 ! 136 136 zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp … … 139 139 zs(ji,jj,jk) = vv(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) ) 140 140 END_3D 141 CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )142 CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )141 CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) 142 CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) 143 143 144 144 CALL iom_put( "voce" , vn_crs ) ! i-current … … 156 156 & + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) ) 157 157 END_3D 158 CALL lbc_lnk( 'crsfld', z3d, 'T', 1. )158 CALL lbc_lnk( 'crsfld', z3d, 'T', 1.0_wp ) 159 159 ! 160 CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 )160 CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) 161 161 CALL iom_put( "eken", zt_crs ) 162 162 ENDIF … … 176 176 END DO 177 177 END DO 178 CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0 )178 CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0_wp ) 179 179 ! 180 180 CALL iom_put( "hdiv", hdivn_crs ) … … 183 183 ! W-velocity 184 184 IF( ln_crs_wn ) THEN 185 CALL crs_dom_ope( ww, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0 )185 CALL crs_dom_ope( ww, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0_wp ) 186 186 ! CALL crs_dom_ope( ww, 'VOL', 'W', tmask, wn_crs, p_e12=e1e2t, p_e3=ze3w ) 187 187 ELSE … … 197 197 SELECT CASE ( nn_crs_kz ) 198 198 CASE ( 0 ) 199 CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )200 CALL crs_dom_ope( avs, 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )199 CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 200 CALL crs_dom_ope( avs, 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 201 201 CASE ( 1 ) 202 CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )203 CALL crs_dom_ope( avs, 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )202 CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 203 CALL crs_dom_ope( avs, 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 204 204 CASE ( 2 ) 205 CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )206 CALL crs_dom_ope( avs, 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )205 CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 206 CALL crs_dom_ope( avs, 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 207 207 END SELECT 208 208 ! … … 211 211 212 212 ! sbc fields 213 CALL crs_dom_ope( ssh(:,:,Kmm) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0 )214 CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u , p_surf_crs=e2u_crs , psgn=1.0 )215 CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v , p_surf_crs=e1v_crs , psgn=1.0 )216 CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )217 CALL crs_dom_ope( rnf , 'MAX', 'T', tmask, rnf_crs , psgn=1.0 )218 CALL crs_dom_ope( qsr , 'SUM', 'T', tmask, qsr_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )219 CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )220 CALL crs_dom_ope( emp , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )221 CALL crs_dom_ope( sfx , 'SUM', 'T', tmask, sfx_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )222 CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )213 CALL crs_dom_ope( ssh(:,:,Kmm) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0_wp ) 214 CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u , p_surf_crs=e2u_crs , psgn=1.0_wp ) 215 CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v , p_surf_crs=e1v_crs , psgn=1.0_wp ) 216 CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 217 CALL crs_dom_ope( rnf , 'MAX', 'T', tmask, rnf_crs , psgn=1.0_wp ) 218 CALL crs_dom_ope( qsr , 'SUM', 'T', tmask, qsr_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 219 CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 220 CALL crs_dom_ope( emp , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 221 CALL crs_dom_ope( sfx , 'SUM', 'T', tmask, sfx_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 222 CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 223 223 224 224 CALL iom_put( "ssh" , sshn_crs ) ! ssh output -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/CRS/crsini.F90
r12680 r13228 211 211 212 212 ! 3.d.3 Vertical depth (meters) 213 CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0 )214 CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0 )213 CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0_wp ) 214 CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0_wp ) 215 215 216 216 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DIA/diaar5.F90
r13193 r13228 327 327 z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk) 328 328 END_3D 329 CALL lbc_lnk( 'diaar5', z2d, 'U', -1. )329 CALL lbc_lnk( 'diaar5', z2d, 'U', -1.0_wp ) 330 330 IF( cptr == 'adv' ) THEN 331 331 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in i-direction … … 341 341 z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk) 342 342 END_3D 343 CALL lbc_lnk( 'diaar5', z2d, 'V', -1. )343 CALL lbc_lnk( 'diaar5', z2d, 'V', -1.0_wp ) 344 344 IF( cptr == 'adv' ) THEN 345 345 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in j-direction -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DIA/diaptr.F90
r12724 r13228 570 570 p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 571 571 END_2D 572 CALL lbc_lnk( 'diaptr', p_fval, 'U', -1. )572 CALL lbc_lnk( 'diaptr', p_fval, 'U', -1.0_wp ) 573 573 END DO 574 574 ! -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DIA/diawri.F90
r13198 r13228 207 207 ! 208 208 END_2D 209 CALL lbc_lnk( 'diawri', z2d, 'T', 1. )209 CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp ) 210 210 CALL iom_put( "taubot", z2d ) 211 211 ENDIF … … 261 261 & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) 262 262 END_2D 263 CALL lbc_lnk( 'diawri', z2d, 'T', 1. )263 CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp ) 264 264 CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient 265 265 z2d(:,:) = SQRT( z2d(:,:) ) … … 293 293 & + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) ) 294 294 END_3D 295 CALL lbc_lnk( 'diawri', z3d, 'T', 1. )295 CALL lbc_lnk( 'diawri', z3d, 'T', 1.0_wp ) 296 296 CALL iom_put( "eken", z3d ) ! kinetic energy 297 297 ENDIF … … 315 315 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) ) 316 316 END_3D 317 CALL lbc_lnk( 'diawri', z2d, 'U', -1. )317 CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp ) 318 318 CALL iom_put( "u_heattr", 0.5*rcp * z2d ) ! heat transport in i-direction 319 319 ENDIF … … 324 324 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) ) 325 325 END_3D 326 CALL lbc_lnk( 'diawri', z2d, 'U', -1. )326 CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp ) 327 327 CALL iom_put( "u_salttr", 0.5 * z2d ) ! heat transport in i-direction 328 328 ENDIF … … 342 342 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) ) 343 343 END_3D 344 CALL lbc_lnk( 'diawri', z2d, 'V', -1. )344 CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp ) 345 345 CALL iom_put( "v_heattr", 0.5*rcp * z2d ) ! heat transport in j-direction 346 346 ENDIF … … 351 351 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) ) 352 352 END_3D 353 CALL lbc_lnk( 'diawri', z2d, 'V', -1. )353 CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp ) 354 354 CALL iom_put( "v_salttr", 0.5 * z2d ) ! heat transport in j-direction 355 355 ENDIF … … 360 360 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) 361 361 END_3D 362 CALL lbc_lnk( 'diawri', z2d, 'T', -1. )362 CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp ) 363 363 CALL iom_put( "tosmint", rho0 * z2d ) ! Vertical integral of temperature 364 364 ENDIF … … 368 368 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) 369 369 END_3D 370 CALL lbc_lnk( 'diawri', z2d, 'T', -1. )370 CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp ) 371 371 CALL iom_put( "somint", rho0 * z2d ) ! Vertical integral of salinity 372 372 ENDIF -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DOM/daymod.F90
r12724 r13228 115 115 116 116 !compute number of days between last Monday and today 117 CALL ymds2ju( 1900, 01, 01, 0.0 , zjul ) ! compute julian day value of 01.01.1900 (our reference that was a Monday)117 CALL ymds2ju( 1900, 01, 01, 0.0_wp, zjul ) ! compute julian day value of 01.01.1900 (our reference that was a Monday) 118 118 inbday = FLOOR(fjulday - zjul) ! compute nb day between 01.01.1900 and start of current day 119 119 imonday = MOD(inbday, 7) ! compute nb day between last monday and current day … … 267 267 ! 268 268 !compute first day of the year in julian days 269 CALL ymds2ju( nyear, 01, 01, 0.0 , fjulstartyear )269 CALL ymds2ju( nyear, 01, 01, 0.0_wp, fjulstartyear ) 270 270 ! 271 271 IF(lwp) WRITE(numout,'(a,i8,a,i4.4,a,i2.2,a,i2.2,a,i3.3)') '======>> time-step =', kt, & -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DOM/dommsk.F90
r13193 r13228 174 174 END DO 175 175 END DO 176 CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1. , vmask, 'V', 1., fmask, 'F', 1.) ! Lateral boundary conditions176 CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1.0_wp, vmask, 'V', 1.0_wp, fmask, 'F', 1.0_wp ) ! Lateral boundary conditions 177 177 178 178 ! Ocean/land mask at wu-, wv- and w points (computed from tmask) -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DOM/domwri.F90
r12377 r13228 209 209 ! 210 210 puniq(:,:) = ztstref(:,:) ! default definition 211 CALL lbc_lnk( 'domwri', puniq, cdgrd, 1. ) ! apply boundary conditions211 CALL lbc_lnk( 'domwri', puniq, cdgrd, 1.0_wp ) ! apply boundary conditions 212 212 lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed 213 213 ! … … 270 270 END DO 271 271 END DO 272 CALL lbc_lnk( 'domwri', zx1, 'T', 1. )272 CALL lbc_lnk( 'domwri', zx1, 'T', 1.0_wp ) 273 273 ! 274 274 IF( PRESENT( px1 ) ) px1 = zx1 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DOM/domzgr.F90
r12377 r13228 322 322 END_2D 323 323 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 324 zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 )325 zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 )326 zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1. ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 )327 ! 328 zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 )329 zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 )324 zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) 325 zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) 326 zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) 327 ! 328 zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) 329 zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) 330 330 ! 331 331 END SUBROUTINE zgr_top_bot -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/divhor.F90
r13193 r13228 94 94 IF( ln_isf ) CALL isf_hdiv( kt, Kmm, hdiv ) !== ice shelf ==! (update hdiv field) 95 95 ! 96 CALL lbc_lnk( 'divhor', hdiv, 'T', 1. ) ! (no sign change)96 CALL lbc_lnk( 'divhor', hdiv, 'T', 1.0_wp ) ! (no sign change) 97 97 ! 98 98 IF( ln_timing ) CALL timing_stop('div_hor') -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynadv_ubs.F90
r12616 r13228 124 124 END_2D 125 125 END DO 126 CALL lbc_lnk_multi( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', 1. , zlu_uv(:,:,:,1), 'U', 1., &127 & zlu_uu(:,:,:,2), 'U', 1. , zlu_uv(:,:,:,2), 'U', 1., &128 & zlv_vv(:,:,:,1), 'V', 1. , zlv_vu(:,:,:,1), 'V', 1., &129 & zlv_vv(:,:,:,2), 'V', 1. , zlv_vu(:,:,:,2), 'V', 1.)126 CALL lbc_lnk_multi( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', 1.0_wp , zlu_uv(:,:,:,1), 'U', 1.0_wp, & 127 & zlu_uu(:,:,:,2), 'U', 1.0_wp , zlu_uv(:,:,:,2), 'U', 1.0_wp, & 128 & zlv_vv(:,:,:,1), 'V', 1.0_wp , zlv_vu(:,:,:,1), 'V', 1.0_wp, & 129 & zlv_vv(:,:,:,2), 'V', 1.0_wp , zlv_vu(:,:,:,2), 'V', 1.0_wp ) 130 130 ! 131 131 ! ! ====================== ! -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynatf.F90
r12748 r13228 165 165 # endif 166 166 ! 167 CALL lbc_lnk_multi( 'dynatf', puu(:,:,:,Kaa), 'U', -1. , pvv(:,:,:,Kaa), 'V', -1.) !* local domain boundaries167 CALL lbc_lnk_multi( 'dynatf', puu(:,:,:,Kaa), 'U', -1.0_wp, pvv(:,:,:,Kaa), 'V', -1.0_wp ) !* local domain boundaries 168 168 ! 169 169 ! !* BDY open boundaries -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynhpg.F90
r12731 r13228 448 448 END IF 449 449 END_2D 450 CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1. , zcpy, 'V', 1.)450 CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 451 451 END IF 452 452 … … 679 679 END IF 680 680 END_2D 681 CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1. , zcpy, 'V', 1.)681 CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 682 682 END IF 683 683 … … 825 825 826 826 END_3D 827 CALL lbc_lnk_multi( 'dynhpg', rho_k, 'W', 1. , rho_i, 'U', 1., rho_j, 'V', 1.)827 CALL lbc_lnk_multi( 'dynhpg', rho_k, 'W', 1.0_wp, rho_i, 'U', 1.0_wp, rho_j, 'V', 1.0_wp ) 828 828 829 829 ! --------------- … … 952 952 ENDIF 953 953 END_2D 954 CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1. , zcpy, 'V', 1.)954 CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 955 955 ENDIF 956 956 … … 1022 1022 END_2D 1023 1023 1024 CALL lbc_lnk_multi ('dynhpg', zsshu_n, 'U', 1. , zsshv_n, 'V', 1.)1024 CALL lbc_lnk_multi ('dynhpg', zsshu_n, 'U', 1.0_wp, zsshv_n, 'V', 1.0_wp ) 1025 1025 1026 1026 DO_2D_00_00 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynkeg.F90
r12377 r13228 121 121 zhke(ji,jj,jk) = r1_48 * ( zv + zu ) 122 122 END_3D 123 CALL lbc_lnk( 'dynkeg', zhke, 'T', 1. )123 CALL lbc_lnk( 'dynkeg', zhke, 'T', 1.0_wp ) 124 124 ! 125 125 END SELECT -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynldf_iso.F90
r12606 r13228 135 135 END_3D 136 136 ! Lateral boundary conditions on the slopes 137 CALL lbc_lnk_multi( 'dynldf_iso', uslp , 'U', -1. , vslp , 'V', -1., wslpi, 'W', -1., wslpj, 'W', -1.)137 CALL lbc_lnk_multi( 'dynldf_iso', uslp , 'U', -1.0_wp, vslp , 'V', -1.0_wp, wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) 138 138 ! 139 139 ENDIF -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynldf_lap_blp.F90
r13193 r13228 132 132 CALL dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 ) ! rotated laplacian applied to pt (output in zlap,Kbb) 133 133 ! 134 CALL lbc_lnk_multi( 'dynldf_lap_blp', zulap, 'U', -1. , zvlap, 'V', -1.) ! Lateral boundary conditions134 CALL lbc_lnk_multi( 'dynldf_lap_blp', zulap, 'U', -1.0_wp, zvlap, 'V', -1.0_wp ) ! Lateral boundary conditions 135 135 ! 136 136 CALL dyn_ldf_lap( kt, Kbb, Kmm, zulap, zvlap, pu_rhs, pv_rhs, 2 ) ! rotated laplacian applied to zlap (output in pt(:,:,:,:,Krhs)) -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynvor.F90
r13193 r13228 242 242 END DO 243 243 244 CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )244 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 245 245 246 246 CASE ( np_CRV ) !* Coriolis + relative vorticity … … 257 257 END DO 258 258 259 CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )259 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 260 260 261 261 END SELECT … … 610 610 END DO ! End of slab 611 611 ! 612 CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )612 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 613 613 614 614 DO jk = 1, jpkm1 ! Horizontal slab … … 731 731 END DO 732 732 ! 733 CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )733 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 734 734 ! 735 735 DO jk = 1, jpkm1 ! Horizontal slab … … 861 861 dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji ,jj-1) ) * 0.5_wp 862 862 END_2D 863 CALL lbc_lnk_multi( 'dynvor', di_e2u_2, 'T', -1. , dj_e1v_2, 'T', -1.) ! Lateral boundary conditions863 CALL lbc_lnk_multi( 'dynvor', di_e2u_2, 'T', -1.0_wp , dj_e1v_2, 'T', -1.0_wp ) ! Lateral boundary conditions 864 864 ! 865 865 CASE DEFAULT !* F-point metric term : pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f) … … 869 869 dj_e1u_2e1e2f(ji,jj) = ( e1u(ji ,jj+1) - e1u(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj) 870 870 END_2D 871 CALL lbc_lnk_multi( 'dynvor', di_e2v_2e1e2f, 'F', -1. , dj_e1u_2e1e2f, 'F', -1.) ! Lateral boundary conditions871 CALL lbc_lnk_multi( 'dynvor', di_e2v_2e1e2f, 'F', -1.0_wp , dj_e1u_2e1e2f, 'F', -1.0_wp ) ! Lateral boundary conditions 872 872 END SELECT 873 873 ! -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/sshwzv.F90
r13219 r13228 118 118 IF ( .NOT.ln_dynspg_ts ) THEN 119 119 IF( ln_bdy ) THEN 120 CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1. ) ! Not sure that's necessary120 CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1.0_wp ) ! Not sure that's necessary 121 121 CALL bdy_ssh( pssh(:,:,Kaa) ) ! Duplicate sea level across open boundaries 122 122 ENDIF … … 181 181 END_2D 182 182 END DO 183 CALL lbc_lnk('sshwzv', zhdiv, 'T', 1. ) ! - ML - Perhaps not necessary: not used for horizontal "connexions"183 CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.0_wp) ! - ML - Perhaps not necessary: not used for horizontal "connexions" 184 184 ! ! Is it problematic to have a wrong vertical velocity in boundary cells? 185 185 ! ! Same question holds for hdiv. Perhaps just for security … … 390 390 END_3D 391 391 ENDIF 392 CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1. )392 CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1.0_wp ) 393 393 ! 394 394 CALL iom_put("Courant",Cu_adv) -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/wet_dry.F90
r12724 r13228 242 242 ENDIF 243 243 END_2D 244 CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1. , zwdlmtv, 'V', 1.)244 CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) 245 245 ! 246 246 CALL mpp_max('wet_dry', jflag) !max over the global domain … … 258 258 ! 259 259 !!gm TO BE SUPPRESSED ? these lbc_lnk are useless since zwdlmtu and zwdlmtv are defined everywhere ! 260 CALL lbc_lnk_multi( 'wet_dry', puu(:,:,:,Kmm) , 'U', -1. , pvv(:,:,:,Kmm) , 'V', -1.)261 CALL lbc_lnk_multi( 'wet_dry', uu_b(:,:,Kmm), 'U', -1. , vv_b(:,:,Kmm), 'V', -1.)260 CALL lbc_lnk_multi( 'wet_dry', puu(:,:,:,Kmm) , 'U', -1.0_wp, pvv(:,:,:,Kmm) , 'V', -1.0_wp ) 261 CALL lbc_lnk_multi( 'wet_dry', uu_b(:,:,Kmm), 'U', -1.0_wp, vv_b(:,:,Kmm), 'V', -1.0_wp ) 262 262 !!gm 263 263 ! … … 367 367 END_2D 368 368 ! 369 CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1. , zwdlmtv, 'V', 1.)369 CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) 370 370 ! 371 371 CALL mpp_max('wet_dry', jflag) !max over the global domain … … 379 379 ! 380 380 !!gm THIS lbc_lnk is useless since it is already done at the end of the jk1-loop 381 CALL lbc_lnk_multi( 'wet_dry', zflxu, 'U', -1. , zflxv, 'V', -1.)381 CALL lbc_lnk_multi( 'wet_dry', zflxu, 'U', -1.0_wp, zflxv, 'V', -1.0_wp ) 382 382 !!gm end 383 383 ! -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ICB/icblbc.F90
r12377 r13228 81 81 TYPE(iceberg), POINTER :: this 82 82 TYPE(point) , POINTER :: pt 83 INTEGER :: iine84 83 !!---------------------------------------------------------------------- 85 84 … … 92 91 DO WHILE( ASSOCIATED(this) ) 93 92 pt => this%current_point 94 iine = INT( pt%xi + 0.5 ) 95 IF( iine > mig(nicbei) ) THEN 93 IF( pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN 96 94 pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp 97 ELSE IF( iine < mig(nicbdi)) THEN95 ELSE IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) THEN 98 96 pt%xi = ricb_left + MOD(pt%xi, 1._wp ) 99 97 ENDIF … … 128 126 pt => this%current_point 129 127 ijne = INT( pt%yj + 0.5 ) 130 IF( ijne .GT. mjg(nicbej)) THEN128 IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN 131 129 ! 132 130 iine = INT( pt%xi + 0.5 ) … … 170 168 INTEGER :: ibergs_rcvd_from_n, ibergs_rcvd_from_s 171 169 INTEGER :: i, ibergs_start, ibergs_end 172 INTEGER :: iine, ijne173 170 INTEGER :: ipe_N, ipe_S, ipe_W, ipe_E 174 171 REAL(wp), DIMENSION(2) :: zewbergs, zwebergs, znsbergs, zsnbergs … … 234 231 DO WHILE (ASSOCIATED(this)) 235 232 pt => this%current_point 236 iine = INT( pt%xi + 0.5 ) 237 IF( ipe_E >= 0 .AND. iine > mig(nicbei) ) THEN 233 IF( ipe_E >= 0 .AND. pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN 238 234 tmpberg => this 239 235 this => this%next … … 248 244 CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e) 249 245 CALL icb_utl_delete(first_berg, tmpberg) 250 ELSE IF( ipe_W >= 0 .AND. iine < mig(nicbdi)) THEN246 ELSE IF( ipe_W >= 0 .AND. pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) THEN 251 247 tmpberg => this 252 248 this => this%next … … 372 368 DO WHILE (ASSOCIATED(this)) 373 369 pt => this%current_point 374 ijne = INT( pt%yj + 0.5 ) 375 IF( ipe_N >= 0 .AND. ijne .GT. mjg(nicbej) ) THEN 370 IF( ipe_N >= 0 .AND. pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN 376 371 tmpberg => this 377 372 this => this%next … … 383 378 CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n) 384 379 CALL icb_utl_delete(first_berg, tmpberg) 385 ELSE IF( ipe_S >= 0 .AND. ijne .LT. mjg(nicbdj)) THEN380 ELSE IF( ipe_S >= 0 .AND. pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp ) THEN 386 381 tmpberg => this 387 382 this => this%next … … 539 534 DO WHILE (ASSOCIATED(this)) 540 535 pt => this%current_point 541 iine = INT( pt%xi + 0.5 ) 542 ijne = INT( pt%yj + 0.5 ) 543 IF( iine .LT. mig(nicbdi) .OR. & 544 iine .GT. mig(nicbei) .OR. & 545 ijne .LT. mjg(nicbdj) .OR. & 546 ijne .GT. mjg(nicbej)) THEN 536 IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp .OR. & 537 pt%xi > REAL(mig(nicbei),wp) + 0.5_wp .OR. & 538 pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp .OR. & 539 pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN 547 540 i = i + 1 548 WRITE(numicb,*) 'berg lost in halo: ', this%number(:) ,iine,ijne541 WRITE(numicb,*) 'berg lost in halo: ', this%number(:) 549 542 WRITE(numicb,*) ' ', nimpp, njmpp 550 543 WRITE(numicb,*) ' ', nicbdi, nicbei, nicbdj, nicbej … … 614 607 pt => this%current_point 615 608 iine = INT( pt%xi + 0.5 ) 616 ijne = INT( pt%yj + 0.5 )617 609 iproc = nicbflddest(mi1(iine)) 618 IF( ijne .GT. mjg(nicbej)) THEN610 IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN 619 611 IF( iproc == ifldproc ) THEN 620 612 ! … … 696 688 ipts = nicbfldpts (mi1(iine)) 697 689 iproc = nicbflddest(mi1(iine)) 698 IF( ijne .GT. mjg(nicbej)) THEN690 IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN 699 691 IF( iproc == ifldproc ) THEN 700 692 ! -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ICB/icbthm.F90
r12291 r13228 57 57 TYPE(point) , POINTER :: pt 58 58 ! 59 COMPLEX( wp), DIMENSION(jpi,jpj) :: cicb_melt, cicb_hflx59 COMPLEX(dp), DIMENSION(jpi,jpj) :: cicb_melt, cicb_hflx 60 60 !!---------------------------------------------------------------------- 61 61 ! 62 62 !! initialiaze cicb_melt and cicb_heat 63 cicb_melt = CMPLX( 0.e0, 0.e0, wp )64 cicb_hflx = CMPLX( 0.e0, 0.e0, wp )63 cicb_melt = CMPLX( 0.e0, 0.e0, dp ) 64 cicb_hflx = CMPLX( 0.e0, 0.e0, dp ) 65 65 ! 66 66 z1_rday = 1._wp / rday … … 176 176 !! the use of DDPDD function for the cumulative sum is needed for reproducibility 177 177 zmelt = ( zdM - ( zdMbitsE - zdMbitsM ) ) * z1_dt ! kg/s 178 CALL DDPDD( CMPLX( zmelt * z1_e1e2, 0.e0, wp ), cicb_melt(ii,ij) )178 CALL DDPDD( CMPLX( zmelt * z1_e1e2, 0.e0, dp ), cicb_melt(ii,ij) ) 179 179 ! 180 180 ! iceberg heat flux … … 185 185 zheat_hcflux = zmelt * pt%heat_density ! heat content flux : kg/s x J/kg = J/s 186 186 zheat_latent = - zmelt * rLfus ! latent heat flux: kg/s x J/kg = J/s 187 CALL DDPDD( CMPLX( ( zheat_hcflux + zheat_latent ) * z1_e1e2, 0.e0, wp ), cicb_hflx(ii,ij) )187 CALL DDPDD( CMPLX( ( zheat_hcflux + zheat_latent ) * z1_e1e2, 0.e0, dp ), cicb_hflx(ii,ij) ) 188 188 ! 189 189 ! diagnostics … … 230 230 END DO 231 231 ! 232 berg_grid%floating_melt = REAL(cicb_melt, wp) ! kg/m2/s233 berg_grid%calving_hflx = REAL(cicb_hflx, wp)232 berg_grid%floating_melt = REAL(cicb_melt,dp) ! kg/m2/s 233 berg_grid%calving_hflx = REAL(cicb_hflx,dp) 234 234 ! 235 235 ! now use melt and associated heat flux in ocean (or not) -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/IOM/iom.F90
r13217 r13228 59 59 PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val 60 60 61 PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 62 PRIVATE iom_g0d, iom_g1d, iom_g2d, iom_g3d, iom_get_123d 63 PRIVATE iom_p1d, iom_p2d, iom_p3d, iom_p4d 61 PRIVATE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp 62 PRIVATE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp 63 PRIVATE iom_get_123d 64 PRIVATE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp 65 PRIVATE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp 66 PRIVATE iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp 67 PRIVATE iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp 64 68 #if defined key_iomput 65 69 PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr … … 70 74 71 75 INTERFACE iom_get 72 MODULE PROCEDURE iom_g0d, iom_g1d, iom_g2d, iom_g3d 76 MODULE PROCEDURE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp 77 MODULE PROCEDURE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp 73 78 END INTERFACE 74 79 INTERFACE iom_getatt … … 79 84 END INTERFACE 80 85 INTERFACE iom_rstput 81 MODULE PROCEDURE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 86 MODULE PROCEDURE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp 87 MODULE PROCEDURE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp 82 88 END INTERFACE 83 89 INTERFACE iom_put 84 MODULE PROCEDURE iom_p0d, iom_p1d, iom_p2d, iom_p3d, iom_p4d 90 MODULE PROCEDURE iom_p0d_sp, iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp 91 MODULE PROCEDURE iom_p0d_dp, iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp 85 92 END INTERFACE iom_put 86 93 … … 169 176 ! 170 177 IF( ln_cfmeta ) THEN ! Add additional grid metadata 171 CALL iom_set_domain_attr("grid_T", area = e1e2t(nldi:nlei, nldj:nlej))172 CALL iom_set_domain_attr("grid_U", area = e1e2u(nldi:nlei, nldj:nlej))173 CALL iom_set_domain_attr("grid_V", area = e1e2v(nldi:nlei, nldj:nlej))174 CALL iom_set_domain_attr("grid_W", area = e1e2t(nldi:nlei, nldj:nlej))178 CALL iom_set_domain_attr("grid_T", area = real( e1e2t(nldi:nlei, nldj:nlej), dp)) 179 CALL iom_set_domain_attr("grid_U", area = real( e1e2u(nldi:nlei, nldj:nlej), dp)) 180 CALL iom_set_domain_attr("grid_V", area = real( e1e2v(nldi:nlei, nldj:nlej), dp)) 181 CALL iom_set_domain_attr("grid_W", area = real( e1e2t(nldi:nlei, nldj:nlej), dp)) 175 182 CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 176 183 CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) … … 192 199 ! 193 200 IF( ln_cfmeta .AND. .NOT. llrst_context) THEN ! Add additional grid metadata 194 CALL iom_set_domain_attr("grid_T", area = e1e2t_crs(nldi:nlei, nldj:nlej))195 CALL iom_set_domain_attr("grid_U", area = e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej))196 CALL iom_set_domain_attr("grid_V", area = e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej))197 CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(nldi:nlei, nldj:nlej))201 CALL iom_set_domain_attr("grid_T", area = real(e1e2t_crs(nldi:nlei, nldj:nlej), dp)) 202 CALL iom_set_domain_attr("grid_U", area = real(e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej), dp) ) 203 CALL iom_set_domain_attr("grid_V", area = real(e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej), dp) ) 204 CALL iom_set_domain_attr("grid_W", area = real(e1e2t_crs(nldi:nlei, nldj:nlej), dp ) ) 198 205 CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 199 206 CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) … … 941 948 !! INTERFACE iom_get 942 949 !!---------------------------------------------------------------------- 943 SUBROUTINE iom_g0d ( kiomid, cdvar, pvar, ktime, ldxios )950 SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime, ldxios ) 944 951 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 945 952 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 946 REAL(wp) , INTENT( out) :: pvar ! read field 953 REAL(sp) , INTENT( out) :: pvar ! read field 954 REAL(dp) :: ztmp_pvar ! tmp var to read field 955 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 956 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart 957 ! 958 INTEGER :: idvar ! variable id 959 INTEGER :: idmspc ! number of spatial dimensions 960 INTEGER , DIMENSION(1) :: itime ! record number 961 CHARACTER(LEN=100) :: clinfo ! info character 962 CHARACTER(LEN=100) :: clname ! file name 963 CHARACTER(LEN=1) :: cldmspc ! 964 LOGICAL :: llxios 965 ! 966 llxios = .FALSE. 967 IF( PRESENT(ldxios) ) llxios = ldxios 968 969 IF(.NOT.llxios) THEN ! read data using default library 970 itime = 1 971 IF( PRESENT(ktime) ) itime = ktime 972 ! 973 clname = iom_file(kiomid)%name 974 clinfo = ' iom_g0d, file: '//trim(clname)//', var: '//trim(cdvar) 975 ! 976 IF( kiomid > 0 ) THEN 977 idvar = iom_varid( kiomid, cdvar ) 978 IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN 979 idmspc = iom_file ( kiomid )%ndims( idvar ) 980 IF( iom_file(kiomid)%luld(idvar) ) idmspc = idmspc - 1 981 WRITE(cldmspc , fmt='(i1)') idmspc 982 IF( idmspc > 0 ) CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', & 983 & 'with 1 or more spatial dimensions: '//cldmspc//' were found.' , & 984 & 'Use ncwa -a to suppress the unnecessary dimensions' ) 985 CALL iom_nf90_get( kiomid, idvar, ztmp_pvar, itime ) 986 pvar = ztmp_pvar 987 ENDIF 988 ENDIF 989 ELSE 990 #if defined key_iomput 991 IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 992 CALL iom_swap( TRIM(crxios_context) ) 993 CALL xios_recv_field( trim(cdvar), pvar) 994 CALL iom_swap( TRIM(cxios_context) ) 995 #else 996 WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) 997 CALL ctl_stop( 'iom_g0d', ctmp1 ) 998 #endif 999 ENDIF 1000 END SUBROUTINE iom_g0d_sp 1001 1002 SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime, ldxios ) 1003 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1004 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1005 REAL(dp) , INTENT( out) :: pvar ! read field 947 1006 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 948 1007 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart … … 989 1048 #endif 990 1049 ENDIF 991 END SUBROUTINE iom_g0d 992 993 SUBROUTINE iom_g1d ( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios )1050 END SUBROUTINE iom_g0d_dp 1051 1052 SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 994 1053 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 995 1054 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 996 1055 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 997 REAL(wp) , INTENT( out), DIMENSION(:) :: pvar ! read field 1056 REAL(sp) , INTENT( out), DIMENSION(:) :: pvar ! read field 1057 REAL(dp) , ALLOCATABLE , DIMENSION(:) :: ztmp_pvar ! tmp var to read field 998 1058 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 999 1059 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading … … 1002 1062 ! 1003 1063 IF( kiomid > 0 ) THEN 1064 IF( iom_file(kiomid)%nfid > 0 ) THEN 1065 ALLOCATE(ztmp_pvar(size(pvar,1))) 1066 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=ztmp_pvar, & 1067 & ktime=ktime, kstart=kstart, kcount=kcount, & 1068 & ldxios=ldxios ) 1069 pvar = ztmp_pvar 1070 DEALLOCATE(ztmp_pvar) 1071 END IF 1072 ENDIF 1073 END SUBROUTINE iom_g1d_sp 1074 1075 1076 SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 1077 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1078 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1079 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1080 REAL(dp) , INTENT( out), DIMENSION(:) :: pvar ! read field 1081 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1082 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading 1083 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis 1084 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1085 ! 1086 IF( kiomid > 0 ) THEN 1004 1087 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & 1005 1088 & ktime=ktime, kstart=kstart, kcount=kcount, & 1006 1089 & ldxios=ldxios ) 1007 1090 ENDIF 1008 END SUBROUTINE iom_g1d 1009 1010 SUBROUTINE iom_g2d ( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios)1091 END SUBROUTINE iom_g1d_dp 1092 1093 SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios) 1011 1094 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1012 1095 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1013 1096 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1014 REAL(wp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1097 REAL(sp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1098 REAL(dp) , ALLOCATABLE , DIMENSION(:,:) :: ztmp_pvar ! tmp var to read field 1015 1099 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1016 1100 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kstart ! start axis position of the reading … … 1023 1107 ! 1024 1108 IF( kiomid > 0 ) THEN 1109 IF( iom_file(kiomid)%nfid > 0 ) THEN 1110 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2))) 1111 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=ztmp_pvar, & 1112 & ktime=ktime, kstart=kstart, kcount=kcount, & 1113 & lrowattr=lrowattr, ldxios=ldxios) 1114 pvar = ztmp_pvar 1115 DEALLOCATE(ztmp_pvar) 1116 END IF 1117 ENDIF 1118 END SUBROUTINE iom_g2d_sp 1119 1120 1121 SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios) 1122 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1123 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1124 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1125 REAL(dp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1126 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1127 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kstart ! start axis position of the reading 1128 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kcount ! number of points in each axis 1129 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 1130 ! look for and use a file attribute 1131 ! called open_ocean_jstart to set the start 1132 ! value for the 2nd dimension (netcdf only) 1133 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1134 ! 1135 IF( kiomid > 0 ) THEN 1025 1136 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=pvar, & 1026 1137 & ktime=ktime, kstart=kstart, kcount=kcount, & 1027 1138 & lrowattr=lrowattr, ldxios=ldxios) 1028 1139 ENDIF 1029 END SUBROUTINE iom_g2d 1030 1031 SUBROUTINE iom_g3d ( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios )1140 END SUBROUTINE iom_g2d_dp 1141 1142 SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios ) 1032 1143 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1033 1144 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1034 1145 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1035 REAL(wp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1146 REAL(sp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1147 REAL(dp) , ALLOCATABLE , DIMENSION(:,:,:) :: ztmp_pvar ! tmp var to read field 1036 1148 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1037 1149 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kstart ! start axis position of the reading … … 1044 1156 ! 1045 1157 IF( kiomid > 0 ) THEN 1158 IF( iom_file(kiomid)%nfid > 0 ) THEN 1159 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3))) 1160 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=ztmp_pvar, & 1161 & ktime=ktime, kstart=kstart, kcount=kcount, & 1162 & lrowattr=lrowattr, ldxios=ldxios ) 1163 pvar = ztmp_pvar 1164 DEALLOCATE(ztmp_pvar) 1165 END IF 1166 ENDIF 1167 END SUBROUTINE iom_g3d_sp 1168 1169 SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios ) 1170 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1171 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1172 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1173 REAL(dp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1174 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1175 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kstart ! start axis position of the reading 1176 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kcount ! number of points in each axis 1177 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 1178 ! look for and use a file attribute 1179 ! called open_ocean_jstart to set the start 1180 ! value for the 2nd dimension (netcdf only) 1181 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1182 ! 1183 IF( kiomid > 0 ) THEN 1046 1184 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=pvar, & 1047 1185 & ktime=ktime, kstart=kstart, kcount=kcount, & 1048 1186 & lrowattr=lrowattr, ldxios=ldxios ) 1049 1187 ENDIF 1050 END SUBROUTINE iom_g3d 1188 END SUBROUTINE iom_g3d_dp 1189 1190 1191 1051 1192 !!---------------------------------------------------------------------- 1052 1193 … … 1065 1206 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1066 1207 CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable 1067 REAL( wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case)1068 REAL( wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case)1069 REAL( wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case)1208 REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 1209 REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 1210 REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 1070 1211 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 1071 1212 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis … … 1096 1237 INTEGER, DIMENSION(jpmax_dims) :: idimsz ! size of the dimensions of the variable 1097 1238 INTEGER, DIMENSION(jpmax_dims) :: ishape ! size of the dimensions of the variable 1098 REAL( wp) :: zscf, zofs ! sacle_factor and add_offset1239 REAL(dp) :: zscf, zofs ! sacle_factor and add_offset 1099 1240 INTEGER :: itmp ! temporary integer 1100 1241 CHARACTER(LEN=256) :: clinfo ! info character … … 1103 1244 LOGICAL :: ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 1104 1245 INTEGER :: inlev ! number of levels for 3D data 1105 REAL( wp) :: gma, gmi1246 REAL(dp) :: gma, gmi 1106 1247 !--------------------------------------------------------------------- 1107 1248 ! … … 1312 1453 !--- overlap areas and extra hallows (mpp) 1313 1454 IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 1314 CALL lbc_lnk( 'iom', pv_r2d,'Z', -999. , kfillmode = jpfillnothing )1455 CALL lbc_lnk( 'iom', pv_r2d,'Z', -999.0_wp, kfillmode = jpfillnothing ) 1315 1456 ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN 1316 1457 ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 1317 1458 IF( icnt(3) == inlev ) THEN 1318 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999. , kfillmode = jpfillnothing )1459 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999.0_wp, kfillmode = jpfillnothing ) 1319 1460 ELSE ! put some arbitrary value (a call to lbc_lnk will be done later...) 1320 1461 DO jj = nlcj+1, jpj ; pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :) ; END DO … … 1341 1482 CALL xios_recv_field( trim(cdvar), pv_r3d) 1342 1483 IF(idom /= jpdom_unknown ) then 1343 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999. , kfillmode = jpfillnothing)1484 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999.0_wp, kfillmode = jpfillnothing) 1344 1485 ENDIF 1345 1486 ELSEIF( PRESENT(pv_r2d) ) THEN … … 1348 1489 CALL xios_recv_field( trim(cdvar), pv_r2d) 1349 1490 IF(idom /= jpdom_unknown ) THEN 1350 CALL lbc_lnk('iom', pv_r2d,'Z',-999. , kfillmode = jpfillnothing)1491 CALL lbc_lnk('iom', pv_r2d,'Z',-999.0_wp, kfillmode = jpfillnothing) 1351 1492 ENDIF 1352 1493 ELSEIF( PRESENT(pv_r1d) ) THEN … … 1363 1504 !some final adjustments 1364 1505 ! C1D case : always call lbc_lnk to replicate the central value over the whole 3X3 domain 1365 IF( lk_c1d .AND. PRESENT(pv_r2d) ) CALL lbc_lnk( 'iom', pv_r2d,'Z',1. )1366 IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1. )1506 IF( lk_c1d .AND. PRESENT(pv_r2d) ) CALL lbc_lnk( 'iom', pv_r2d,'Z',1.0_wp ) 1507 IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1.0_wp ) 1367 1508 1368 1509 !--- Apply scale_factor and offset … … 1551 1692 !! INTERFACE iom_rstput 1552 1693 !!---------------------------------------------------------------------- 1553 SUBROUTINE iom_rp0d ( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1694 SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1554 1695 INTEGER , INTENT(in) :: kt ! ocean time-step 1555 1696 INTEGER , INTENT(in) :: kwrite ! writing time-step 1556 1697 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1557 1698 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1558 REAL( wp) , INTENT(in) :: pvar ! written field1699 REAL(sp) , INTENT(in) :: pvar ! written field 1559 1700 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1560 1701 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1575 1716 IF( iom_file(kiomid)%nfid > 0 ) THEN 1576 1717 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1577 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar)1718 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = real(pvar, dp) ) 1578 1719 ENDIF 1579 1720 ENDIF 1580 1721 ENDIF 1581 END SUBROUTINE iom_rp0d 1582 1583 SUBROUTINE iom_rp 1d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1722 END SUBROUTINE iom_rp0d_sp 1723 1724 SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1584 1725 INTEGER , INTENT(in) :: kt ! ocean time-step 1585 1726 INTEGER , INTENT(in) :: kwrite ! writing time-step 1586 1727 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1587 1728 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1588 REAL(wp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1729 REAL(dp) , INTENT(in) :: pvar ! written field 1730 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1731 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1732 LOGICAL :: llx ! local xios write flag 1733 INTEGER :: ivid ! variable id 1734 1735 llx = .FALSE. 1736 IF(PRESENT(ldxios)) llx = ldxios 1737 IF( llx ) THEN 1738 #ifdef key_iomput 1739 IF( kt == kwrite ) THEN 1740 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1741 CALL xios_send_field(trim(cdvar), pvar) 1742 ENDIF 1743 #endif 1744 ELSE 1745 IF( kiomid > 0 ) THEN 1746 IF( iom_file(kiomid)%nfid > 0 ) THEN 1747 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1748 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) 1749 ENDIF 1750 ENDIF 1751 ENDIF 1752 END SUBROUTINE iom_rp0d_dp 1753 1754 1755 SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1756 INTEGER , INTENT(in) :: kt ! ocean time-step 1757 INTEGER , INTENT(in) :: kwrite ! writing time-step 1758 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1759 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1760 REAL(sp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1589 1761 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1590 1762 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1605 1777 IF( iom_file(kiomid)%nfid > 0 ) THEN 1606 1778 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1607 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar)1779 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = real(pvar, dp) ) 1608 1780 ENDIF 1609 1781 ENDIF 1610 1782 ENDIF 1611 END SUBROUTINE iom_rp1d 1612 1613 SUBROUTINE iom_rp 2d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1783 END SUBROUTINE iom_rp1d_sp 1784 1785 SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1614 1786 INTEGER , INTENT(in) :: kt ! ocean time-step 1615 1787 INTEGER , INTENT(in) :: kwrite ! writing time-step 1616 1788 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1617 1789 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1618 REAL(wp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1790 REAL(dp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1791 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1792 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1793 LOGICAL :: llx ! local xios write flag 1794 INTEGER :: ivid ! variable id 1795 1796 llx = .FALSE. 1797 IF(PRESENT(ldxios)) llx = ldxios 1798 IF( llx ) THEN 1799 #ifdef key_iomput 1800 IF( kt == kwrite ) THEN 1801 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1802 CALL xios_send_field(trim(cdvar), pvar) 1803 ENDIF 1804 #endif 1805 ELSE 1806 IF( kiomid > 0 ) THEN 1807 IF( iom_file(kiomid)%nfid > 0 ) THEN 1808 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1809 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) 1810 ENDIF 1811 ENDIF 1812 ENDIF 1813 END SUBROUTINE iom_rp1d_dp 1814 1815 1816 SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1817 INTEGER , INTENT(in) :: kt ! ocean time-step 1818 INTEGER , INTENT(in) :: kwrite ! writing time-step 1819 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1820 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1821 REAL(sp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1619 1822 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1620 1823 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1635 1838 IF( iom_file(kiomid)%nfid > 0 ) THEN 1636 1839 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1637 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar)1840 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = real(pvar, dp) ) 1638 1841 ENDIF 1639 1842 ENDIF 1640 1843 ENDIF 1641 END SUBROUTINE iom_rp2d 1642 1643 SUBROUTINE iom_rp 3d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1844 END SUBROUTINE iom_rp2d_sp 1845 1846 SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1644 1847 INTEGER , INTENT(in) :: kt ! ocean time-step 1645 1848 INTEGER , INTENT(in) :: kwrite ! writing time-step 1646 1849 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1647 1850 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1648 REAL(wp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1851 REAL(dp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1852 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1853 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1854 LOGICAL :: llx 1855 INTEGER :: ivid ! variable id 1856 1857 llx = .FALSE. 1858 IF(PRESENT(ldxios)) llx = ldxios 1859 IF( llx ) THEN 1860 #ifdef key_iomput 1861 IF( kt == kwrite ) THEN 1862 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1863 CALL xios_send_field(trim(cdvar), pvar) 1864 ENDIF 1865 #endif 1866 ELSE 1867 IF( kiomid > 0 ) THEN 1868 IF( iom_file(kiomid)%nfid > 0 ) THEN 1869 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1870 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) 1871 ENDIF 1872 ENDIF 1873 ENDIF 1874 END SUBROUTINE iom_rp2d_dp 1875 1876 1877 SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1878 INTEGER , INTENT(in) :: kt ! ocean time-step 1879 INTEGER , INTENT(in) :: kwrite ! writing time-step 1880 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1881 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1882 REAL(sp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1649 1883 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1650 1884 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1665 1899 IF( iom_file(kiomid)%nfid > 0 ) THEN 1666 1900 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1901 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = real(pvar, dp) ) 1902 ENDIF 1903 ENDIF 1904 ENDIF 1905 END SUBROUTINE iom_rp3d_sp 1906 1907 SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1908 INTEGER , INTENT(in) :: kt ! ocean time-step 1909 INTEGER , INTENT(in) :: kwrite ! writing time-step 1910 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1911 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1912 REAL(dp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1913 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1914 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1915 LOGICAL :: llx ! local xios write flag 1916 INTEGER :: ivid ! variable id 1917 1918 llx = .FALSE. 1919 IF(PRESENT(ldxios)) llx = ldxios 1920 IF( llx ) THEN 1921 #ifdef key_iomput 1922 IF( kt == kwrite ) THEN 1923 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1924 CALL xios_send_field(trim(cdvar), pvar) 1925 ENDIF 1926 #endif 1927 ELSE 1928 IF( kiomid > 0 ) THEN 1929 IF( iom_file(kiomid)%nfid > 0 ) THEN 1930 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1667 1931 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) 1668 1932 ENDIF 1669 1933 ENDIF 1670 1934 ENDIF 1671 END SUBROUTINE iom_rp3d 1935 END SUBROUTINE iom_rp3d_dp 1936 1672 1937 1673 1938 … … 1721 1986 !! INTERFACE iom_put 1722 1987 !!---------------------------------------------------------------------- 1723 SUBROUTINE iom_p0d ( cdname, pfield0d )1988 SUBROUTINE iom_p0d_sp( cdname, pfield0d ) 1724 1989 CHARACTER(LEN=*), INTENT(in) :: cdname 1725 REAL( wp) , INTENT(in) :: pfield0d1990 REAL(sp) , INTENT(in) :: pfield0d 1726 1991 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1727 1992 #if defined key_iomput … … 1732 1997 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings 1733 1998 #endif 1734 END SUBROUTINE iom_p0d 1735 1736 SUBROUTINE iom_p1d( cdname, pfield1d ) 1999 END SUBROUTINE iom_p0d_sp 2000 2001 SUBROUTINE iom_p0d_dp( cdname, pfield0d ) 2002 CHARACTER(LEN=*), INTENT(in) :: cdname 2003 REAL(dp) , INTENT(in) :: pfield0d 2004 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 2005 #if defined key_iomput 2006 !!clem zz(:,:)=pfield0d 2007 !!clem CALL xios_send_field(cdname, zz) 2008 CALL xios_send_field(cdname, (/pfield0d/)) 2009 #else 2010 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings 2011 #endif 2012 END SUBROUTINE iom_p0d_dp 2013 2014 2015 SUBROUTINE iom_p1d_sp( cdname, pfield1d ) 1737 2016 CHARACTER(LEN=*) , INTENT(in) :: cdname 1738 REAL( wp), DIMENSION(:), INTENT(in) :: pfield1d2017 REAL(sp), DIMENSION(:), INTENT(in) :: pfield1d 1739 2018 #if defined key_iomput 1740 2019 CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) … … 1742 2021 IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings 1743 2022 #endif 1744 END SUBROUTINE iom_p1d 1745 1746 SUBROUTINE iom_p2d( cdname, pfield2d ) 2023 END SUBROUTINE iom_p1d_sp 2024 2025 SUBROUTINE iom_p1d_dp( cdname, pfield1d ) 2026 CHARACTER(LEN=*) , INTENT(in) :: cdname 2027 REAL(dp), DIMENSION(:), INTENT(in) :: pfield1d 2028 #if defined key_iomput 2029 CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) 2030 #else 2031 IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings 2032 #endif 2033 END SUBROUTINE iom_p1d_dp 2034 2035 SUBROUTINE iom_p2d_sp( cdname, pfield2d ) 1747 2036 CHARACTER(LEN=*) , INTENT(in) :: cdname 1748 REAL( wp), DIMENSION(:,:), INTENT(in) :: pfield2d2037 REAL(sp), DIMENSION(:,:), INTENT(in) :: pfield2d 1749 2038 #if defined key_iomput 1750 2039 CALL xios_send_field(cdname, pfield2d) … … 1752 2041 IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings 1753 2042 #endif 1754 END SUBROUTINE iom_p2d 1755 1756 SUBROUTINE iom_p3d( cdname, pfield3d ) 2043 END SUBROUTINE iom_p2d_sp 2044 2045 SUBROUTINE iom_p2d_dp( cdname, pfield2d ) 2046 CHARACTER(LEN=*) , INTENT(in) :: cdname 2047 REAL(dp), DIMENSION(:,:), INTENT(in) :: pfield2d 2048 #if defined key_iomput 2049 CALL xios_send_field(cdname, pfield2d) 2050 #else 2051 IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings 2052 #endif 2053 END SUBROUTINE iom_p2d_dp 2054 2055 SUBROUTINE iom_p3d_sp( cdname, pfield3d ) 1757 2056 CHARACTER(LEN=*) , INTENT(in) :: cdname 1758 REAL( wp), DIMENSION(:,:,:), INTENT(in) :: pfield3d2057 REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 1759 2058 #if defined key_iomput 1760 2059 CALL xios_send_field( cdname, pfield3d ) … … 1762 2061 IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings 1763 2062 #endif 1764 END SUBROUTINE iom_p3d 1765 1766 SUBROUTINE iom_p 4d( cdname, pfield4d )2063 END SUBROUTINE iom_p3d_sp 2064 2065 SUBROUTINE iom_p3d_dp( cdname, pfield3d ) 1767 2066 CHARACTER(LEN=*) , INTENT(in) :: cdname 1768 REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 2067 REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 2068 #if defined key_iomput 2069 CALL xios_send_field( cdname, pfield3d ) 2070 #else 2071 IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings 2072 #endif 2073 END SUBROUTINE iom_p3d_dp 2074 2075 SUBROUTINE iom_p4d_sp( cdname, pfield4d ) 2076 CHARACTER(LEN=*) , INTENT(in) :: cdname 2077 REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 1769 2078 #if defined key_iomput 1770 2079 CALL xios_send_field(cdname, pfield4d) … … 1772 2081 IF( .FALSE. ) WRITE(numout,*) cdname, pfield4d ! useless test to avoid compilation warnings 1773 2082 #endif 1774 END SUBROUTINE iom_p4d 1775 2083 END SUBROUTINE iom_p4d_sp 2084 2085 SUBROUTINE iom_p4d_dp( cdname, pfield4d ) 2086 CHARACTER(LEN=*) , INTENT(in) :: cdname 2087 REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 2088 #if defined key_iomput 2089 CALL xios_send_field(cdname, pfield4d) 2090 #else 2091 IF( .FALSE. ) WRITE(numout,*) cdname, pfield4d ! useless test to avoid compilation warnings 2092 #endif 2093 END SUBROUTINE iom_p4d_dp 1776 2094 1777 2095 #if defined key_iomput … … 1789 2107 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1790 2108 INTEGER , OPTIONAL, INTENT(in) :: nvertex 1791 REAL( wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue1792 REAL( wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area2109 REAL(dp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 2110 REAL(dp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1793 2111 LOGICAL , DIMENSION(:) , OPTIONAL, INTENT(in) :: mask 1794 2112 !!---------------------------------------------------------------------- … … 1853 2171 !!---------------------------------------------------------------------- 1854 2172 IF( PRESENT(paxis) ) THEN 1855 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=paxis ) 1856 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 1857 ENDIF 1858 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=bounds ) 1859 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 2173 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 2174 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 2175 ENDIF 2176 IF( PRESENT(bounds) ) THEN 2177 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=real(bounds, dp) ) 2178 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=real(bounds, dp) ) 2179 ELSE 2180 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid) 2181 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid) 2182 END IF 1860 2183 CALL xios_solve_inheritance() 1861 2184 END SUBROUTINE iom_set_axis_attr … … 1976 2299 !don't define lon and lat for restart reading context. 1977 2300 IF ( .NOT.ldrxios ) & 1978 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), &1979 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))2301 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = real(RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), dp), & 2302 & latvalue = real(RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)),dp ) ) 1980 2303 ! 1981 2304 IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN … … 1983 2306 SELECT CASE ( cdgrd ) 1984 2307 CASE('T') ; zmask(:,:,:) = tmask(:,:,:) 1985 CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( 'iom', zmask, 'U', 1. )1986 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( 'iom', zmask, 'V', 1. )2308 CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( 'iom', zmask, 'U', 1.0_wp ) 2309 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( 'iom', zmask, 'V', 1.0_wp ) 1987 2310 CASE('W') ; zmask(:,:,2:jpk ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk) ; zmask(:,:,1) = tmask(:,:,1) 1988 2311 END SELECT … … 2027 2350 ! 2028 2351 z_fld(:,:) = 1._wp 2029 CALL lbc_lnk( 'iom', z_fld, cdgrd, -1. ) ! Working array for location of northfold2352 CALL lbc_lnk( 'iom', z_fld, cdgrd, -1.0_wp ) ! Working array for location of northfold 2030 2353 ! 2031 2354 ! Cell vertices that can be defined … … 2045 2368 ! Cell vertices on boundries 2046 2369 DO jn = 1, 4 2047 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1. , pfillval=999._wp )2048 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1. , pfillval=999._wp )2370 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1.0_wp, pfillval=999._wp ) 2371 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1.0_wp, pfillval=999._wp ) 2049 2372 END DO 2050 2373 ! … … 2092 2415 ENDIF 2093 2416 ! 2094 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), &2095 & bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 )2417 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat =real( RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), dp), & 2418 & bounds_lon =real( RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), dp), nvertex=4 ) 2096 2419 ! 2097 2420 DEALLOCATE( z_bnds, z_fld, z_rot ) … … 2117 2440 ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0._wp 2118 2441 ! 2119 ! CALL dom_ngb( -168.53 , 65.03, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots)2120 CALL dom_ngb( 180. , 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots)2442 ! CALL dom_ngb( -168.53_wp, 65.03_wp, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) 2443 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) 2121 2444 CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 2122 2445 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 2123 CALL iom_set_domain_attr("gznl", lonvalue = zlon, &2124 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))2446 CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp), & 2447 & latvalue = real(RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)),dp)) 2125 2448 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 2126 2449 ! … … 2137 2460 !! 2138 2461 !!---------------------------------------------------------------------- 2139 REAL( wp), DIMENSION(1) :: zz = 1.2462 REAL(dp), DIMENSION(1) :: zz = 1. 2140 2463 !!---------------------------------------------------------------------- 2141 2464 ! … … 2199 2522 cl1 = clgrd(jg) 2200 2523 ! Equatorial section (attributs: jbegin, ni, name_suffix) 2201 CALL dom_ngb( 0. , 0., ix, iy, cl1 )2524 CALL dom_ngb( 0.0_wp, 0.0_wp, ix, iy, cl1 ) 2202 2525 CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni=jpiglo, nj=1 ) 2203 2526 CALL iom_get_file_attr ('Eq'//cl1, name_suffix = clsuff ) … … 2425 2748 ! 2426 2749 IF ( ll24 .AND. isec == 0 ) THEN ! 00:00 of the next day -> move to 24:00 of the current day 2427 CALL ju2ymds( pjday - 1. , iyear, imonth, iday, zsec )2750 CALL ju2ymds( pjday - 1.0_wp, iyear, imonth, iday, zsec ) 2428 2751 isec = 86400 2429 2752 ENDIF … … 2483 2806 CHARACTER(LEN=*), INTENT(in ) :: cdname 2484 2807 REAL(wp) , INTENT(out) :: pmiss_val 2808 REAL(dp) :: ztmp_pmiss_val 2485 2809 #if defined key_iomput 2486 2810 ! get missing value 2487 CALL xios_get_field_attr( cdname, default_value = pmiss_val ) 2811 CALL xios_get_field_attr( cdname, default_value = ztmp_pmiss_val ) 2812 pmiss_val = ztmp_pmiss_val 2488 2813 #else 2489 2814 IF( .FALSE. ) WRITE(numout,*) cdname, pmiss_val ! useless test to avoid compilation warnings -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/IOM/iom_nf90.F90
r13193 r13228 33 33 34 34 INTERFACE iom_nf90_get 35 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 36 37 END INTERFACE 37 38 INTERFACE iom_nf90_rstput 38 MODULE PROCEDURE iom_nf90_rp0123d 39 MODULE PROCEDURE iom_nf90_rp0123d_dp 39 40 END INTERFACE 40 41 … … 276 277 !!---------------------------------------------------------------------- 277 278 278 SUBROUTINE iom_nf90_g0d ( kiomid, kvid, pvar, kstart )279 SUBROUTINE iom_nf90_g0d_sp( kiomid, kvid, pvar, kstart ) 279 280 !!----------------------------------------------------------------------- 280 281 !! *** ROUTINE iom_nf90_g0d *** … … 284 285 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 285 286 INTEGER , INTENT(in ) :: kvid ! variable id 286 REAL( wp), INTENT( out) :: pvar ! read field287 REAL(sp), INTENT( out) :: pvar ! read field 287 288 INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 288 289 ! … … 291 292 clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) 292 293 CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) 293 END SUBROUTINE iom_nf90_g0d 294 295 296 SUBROUTINE iom_nf90_g123d( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, & 294 END SUBROUTINE iom_nf90_g0d_sp 295 296 SUBROUTINE iom_nf90_g0d_dp( kiomid, kvid, pvar, kstart ) 297 !!----------------------------------------------------------------------- 298 !! *** ROUTINE iom_nf90_g0d *** 299 !! 300 !! ** Purpose : read a scalar with NF90 301 !!----------------------------------------------------------------------- 302 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 303 INTEGER , INTENT(in ) :: kvid ! variable id 304 REAL(dp), INTENT( out) :: pvar ! read field 305 INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 306 ! 307 CHARACTER(LEN=100) :: clinfo ! info character 308 !--------------------------------------------------------------------- 309 clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) 310 CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) 311 END SUBROUTINE iom_nf90_g0d_dp 312 313 SUBROUTINE iom_nf90_g123d_dp( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, & 297 314 & pv_r1d, pv_r2d, pv_r3d ) 298 315 !!----------------------------------------------------------------------- … … 309 326 INTEGER , DIMENSION(:) , INTENT(in ) :: kcount ! number of points to be read in each axis 310 327 INTEGER , INTENT(in ) :: kx1, kx2, ky1, ky2 ! subdomain indexes 311 REAL( wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case)312 REAL( wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case)313 REAL( wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case)328 REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 329 REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 330 REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 314 331 ! 315 332 CHARACTER(LEN=100) :: clinfo ! info character … … 332 349 ENDIF 333 350 ! 334 END SUBROUTINE iom_nf90_g123d 351 END SUBROUTINE iom_nf90_g123d_dp 352 335 353 336 354 … … 506 524 END SUBROUTINE iom_nf90_putatt 507 525 508 509 SUBROUTINE iom_nf90_rp0123d( kt, kwrite, kiomid, cdvar , kvid , ktype, & 526 SUBROUTINE iom_nf90_rp0123d_dp( kt, kwrite, kiomid, cdvar , kvid , ktype, & 510 527 & pv_r0d, pv_r1d, pv_r2d, pv_r3d ) 511 528 !!-------------------------------------------------------------------- … … 520 537 INTEGER , INTENT(in) :: kvid ! variable id 521 538 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable type (default R8) 522 REAL( wp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field523 REAL( wp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field524 REAL( wp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field525 REAL( wp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field539 REAL(dp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field 540 REAL(dp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field 541 REAL(dp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field 542 REAL(dp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field 526 543 ! 527 544 INTEGER :: idims ! number of dimension … … 704 721 ENDIF 705 722 ! 706 END SUBROUTINE iom_nf90_rp0123d 723 END SUBROUTINE iom_nf90_rp0123d_dp 707 724 708 725 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ISF/isfcav.F90
r12724 r13228 136 136 ! 137 137 ! lbclnk on melt 138 CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1. , pqfwf, 'T', 1.)138 CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1.0_wp, pqfwf, 'T', 1.0_wp) 139 139 ! 140 140 ! output fluxes -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ISF/isfcpl.F90
r12732 r13228 212 212 zssmask0(:,:) = zssmask_b(:,:) 213 213 ! 214 CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1. , zssmask0, 'T', 1.)214 CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1.0_wp, zssmask0, 'T', 1.0_wp ) 215 215 ! 216 216 END DO … … 367 367 ztmask0(:,:,:) = ztmask1(:,:,:) 368 368 ! 369 CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1. , zts0(:,:,:,jp_sal), 'T', 1., ztmask0, 'T', 1.)369 CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1.0_wp, zts0(:,:,:,jp_sal), 'T', 1.0_wp, ztmask0, 'T', 1.0_wp) 370 370 ! 371 371 END DO ! nn_drown … … 458 458 END_2D 459 459 ! 460 CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1. )460 CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1.0_wp ) 461 461 ! 462 462 ! 3.0: set total correction (div, tr(:,:,:,:,Krhs), ssh) … … 630 630 ELSE IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN 631 631 ! spread correction amoung neigbourg wet cells (vertical direction) 632 CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1. , 0)632 CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1.0_wp, 0) 633 633 ELSE 634 634 ! need to find where to put correction in later on 635 CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1. , 1)635 CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1.0_wp, 1) 636 636 END IF 637 637 END IF … … 693 693 ! 694 694 ! add lbclnk 695 CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1. , risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1., &696 & risfcpl_cons_vol(:,:,:) , 'T', 1. )695 CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_wp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_wp, & 696 & risfcpl_cons_vol(:,:,:) , 'T', 1.0_wp) 697 697 ! 698 698 ! ssh correction (for dynspg_ts) -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ISF/isfpar.F90
r12724 r13228 82 82 ! 83 83 ! lbclnk on melt and heat fluxes 84 CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1. , pqfwf, 'T', 1.)84 CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1.0_wp, pqfwf, 'T', 1.0_wp) 85 85 ! 86 86 ! output fluxes -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lbc_lnk_multi_generic.h90
r11536 r13228 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 5 #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 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 15 35 #endif 16 36 … … 79 99 END SUBROUTINE ROUTINE_LOAD 80 100 101 #undef PRECISION 81 102 #undef ARRAY_TYPE 82 103 #undef PTR_TYPE -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lbc_nfd_ext_generic.h90
r10525 r13228 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 ) … … 149 155 END SUBROUTINE ROUTINE_NFD 150 156 157 #undef PRECISION 151 158 #undef ARRAY_TYPE 152 159 #undef ARRAY_IN -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lbc_nfd_generic.h90
r10425 r13228 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) … … 41 53 # define L_SIZE(ptab) SIZE(ptab,4) 42 54 # endif 43 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 55 # if defined SINGLE_PRECISION 56 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 57 # else 58 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 59 # endif 44 60 #endif 61 62 # if defined SINGLE_PRECISION 63 # define PRECISION sp 64 # else 65 # define PRECISION dp 66 # endif 45 67 46 68 #if defined MULTI … … 167 189 END SUBROUTINE ROUTINE_NFD 168 190 191 #undef PRECISION 169 192 #undef ARRAY_TYPE 170 193 #undef ARRAY_IN -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r11536 r13228 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) … … 46 62 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l) 47 63 # 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 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 !!---------------------------------------------------------------------- … … 345 370 END DO ! End jf loop 346 371 END SUBROUTINE ROUTINE_NFD 372 #undef PRECISION 347 373 #undef ARRAY_TYPE 348 374 #undef ARRAY_IN -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lbclnk.F90
r12377 r13228 28 28 29 29 INTERFACE lbc_lnk 30 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 31 32 END INTERFACE 32 33 INTERFACE lbc_lnk_ptr 33 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 34 36 END INTERFACE 35 37 INTERFACE lbc_lnk_multi 36 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 37 40 END INTERFACE 38 41 ! 39 42 INTERFACE lbc_lnk_icb 40 MODULE PROCEDURE mpp_lnk_2d_icb 43 MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp 41 44 END INTERFACE 42 45 43 46 INTERFACE mpp_nfd 44 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 45 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 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 46 52 END INTERFACE 47 53 … … 92 98 !!---------------------------------------------------------------------- 93 99 94 # define DIM_2d 95 # define ROUTINE_LOAD load_ptr_2d 96 # define ROUTINE_MULTI lbc_lnk_2d_multi 97 # include "lbc_lnk_multi_generic.h90" 98 # undef ROUTINE_MULTI 99 # undef ROUTINE_LOAD 100 # undef DIM_2d 101 102 # define DIM_3d 103 # define ROUTINE_LOAD load_ptr_3d 104 # define ROUTINE_MULTI lbc_lnk_3d_multi 105 # include "lbc_lnk_multi_generic.h90" 106 # undef ROUTINE_MULTI 107 # undef ROUTINE_LOAD 108 # undef DIM_3d 109 110 # define DIM_4d 111 # define ROUTINE_LOAD load_ptr_4d 112 # define ROUTINE_MULTI lbc_lnk_4d_multi 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 113 151 # include "lbc_lnk_multi_generic.h90" 114 152 # undef ROUTINE_MULTI … … 130 168 ! !== 2D array and array of 2D pointer ==! 131 169 ! 132 # define DIM_2d 133 # define ROUTINE_LNK mpp_lnk_2d 134 # include "mpp_lnk_generic.h90" 135 # undef ROUTINE_LNK 136 # define MULTI 137 # define ROUTINE_LNK mpp_lnk_2d_ptr 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 138 180 # include "mpp_lnk_generic.h90" 139 181 # undef ROUTINE_LNK … … 144 186 ! 145 187 # define DIM_3d 146 # define ROUTINE_LNK mpp_lnk_3d 147 # include "mpp_lnk_generic.h90" 148 # undef ROUTINE_LNK 149 # define MULTI 150 # define ROUTINE_LNK mpp_lnk_3d_ptr 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 151 193 # include "mpp_lnk_generic.h90" 152 194 # undef ROUTINE_LNK … … 157 199 ! 158 200 # define DIM_4d 159 # define ROUTINE_LNK mpp_lnk_4d 160 # include "mpp_lnk_generic.h90" 161 # undef ROUTINE_LNK 162 # define MULTI 163 # define ROUTINE_LNK mpp_lnk_4d_ptr 164 # include "mpp_lnk_generic.h90" 165 # undef ROUTINE_LNK 166 # undef MULTI 167 # undef 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 168 252 169 253 !!---------------------------------------------------------------------- … … 181 265 ! !== 2D array and array of 2D pointer ==! 182 266 ! 183 # define DIM_2d 184 # define ROUTINE_NFD mpp_nfd_2d 185 # include "mpp_nfd_generic.h90" 186 # undef ROUTINE_NFD 187 # define MULTI 188 # define ROUTINE_NFD mpp_nfd_2d_ptr 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 189 277 # include "mpp_nfd_generic.h90" 190 278 # undef ROUTINE_NFD … … 195 283 ! 196 284 # define DIM_3d 197 # define ROUTINE_NFD mpp_nfd_3d 198 # include "mpp_nfd_generic.h90" 199 # undef ROUTINE_NFD 200 # define MULTI 201 # define ROUTINE_NFD mpp_nfd_3d_ptr 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 202 290 # include "mpp_nfd_generic.h90" 203 291 # undef ROUTINE_NFD … … 208 296 ! 209 297 # define DIM_4d 210 # define ROUTINE_NFD mpp_nfd_4d 211 # include "mpp_nfd_generic.h90" 212 # undef ROUTINE_NFD 213 # define MULTI 214 # define ROUTINE_NFD mpp_nfd_4d_ptr 215 # include "mpp_nfd_generic.h90" 216 # undef ROUTINE_NFD 217 # undef MULTI 218 # undef DIM_4d 219 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 347 # undef DIM_4d 220 348 221 349 !!====================================================================== 222 350 223 351 224 225 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 226 !!--------------------------------------------------------------------- 352 !!====================================================================== 353 !!--------------------------------------------------------------------- 227 354 !! *** routine mpp_lbc_north_icb *** 228 355 !! … … 240 367 !! 241 368 !!---------------------------------------------------------------------- 242 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo 243 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 244 ! ! = T , U , V , F or W -points 245 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 246 !! ! north fold, = 1. otherwise 247 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold 248 ! 249 INTEGER :: ji, jj, jr 250 INTEGER :: ierr, itaille, ildi, ilei, iilb 251 INTEGER :: ipj, ij, iproc 252 ! 253 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 254 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 255 !!---------------------------------------------------------------------- 256 #if defined key_mpp_mpi 257 ! 258 ipj=4 259 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & 260 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & 261 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) ) 262 ! 263 ztab_e(:,:) = 0._wp 264 znorthloc_e(:,:) = 0._wp 265 ! 266 ij = 1 - kextj 267 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e 268 DO jj = jpj - ipj + 1 - kextj , jpj + kextj 269 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 270 ij = ij + 1 271 END DO 272 ! 273 itaille = jpimax * ( ipj + 2*kextj ) 274 ! 275 IF( ln_timing ) CALL tic_tac(.TRUE.) 276 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, & 277 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, & 278 & ncomm_north, ierr ) 279 ! 280 IF( ln_timing ) CALL tic_tac(.FALSE.) 281 ! 282 DO jr = 1, ndim_rank_north ! recover the global north array 283 iproc = nrank_north(jr) + 1 284 ildi = nldit (iproc) 285 ilei = nleit (iproc) 286 iilb = nimppt(iproc) 287 DO jj = 1-kextj, ipj+kextj 288 DO ji = ildi, ilei 289 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 290 END DO 291 END DO 292 END DO 293 294 ! 2. North-Fold boundary conditions 295 ! ---------------------------------- 296 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 297 298 ij = 1 - kextj 299 !! Scatter back to pt2d 300 DO jj = jpj - ipj + 1 - kextj , jpj + kextj 301 DO ji= 1, jpi 302 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 303 END DO 304 ij = ij +1 305 END DO 306 ! 307 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 308 ! 309 #endif 310 END SUBROUTINE mpp_lbc_north_icb 311 312 313 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 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 314 379 !!---------------------------------------------------------------------- 315 380 !! *** routine mpp_lnk_2d_icb *** … … 333 398 !! nono : number for local neighboring processors 334 399 !!---------------------------------------------------------------------- 335 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 336 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo 337 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 338 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 339 INTEGER , INTENT(in ) :: kexti ! extra i-halo width 340 INTEGER , INTENT(in ) :: kextj ! extra j-halo width 341 ! 342 INTEGER :: jl ! dummy loop indices 343 INTEGER :: imigr, iihom, ijhom ! local integers 344 INTEGER :: ipreci, iprecj ! - - 345 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 346 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 347 !! 348 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn 349 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew 350 !!---------------------------------------------------------------------- 351 352 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area 353 iprecj = nn_hls + kextj 354 355 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 356 357 ! 1. standard boundary treatment 358 ! ------------------------------ 359 ! Order matters Here !!!! 360 ! 361 ! ! East-West boundaries 362 ! !* Cyclic east-west 363 IF( l_Iperio ) THEN 364 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east 365 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west 366 ! 367 ELSE !* closed 368 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point 369 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west 370 ENDIF 371 ! ! North-South boundaries 372 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) 373 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north 374 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south 375 ELSE !* closed 376 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point 377 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south 378 ENDIF 379 ! 380 381 ! north fold treatment 382 ! ----------------------- 383 IF( npolj /= 0 ) THEN 384 ! 385 SELECT CASE ( jpni ) 386 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 387 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 388 END SELECT 389 ! 390 ENDIF 391 392 ! 2. East and west directions exchange 393 ! ------------------------------------ 394 ! we play with the neigbours AND the row number because of the periodicity 395 ! 396 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 397 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 398 iihom = jpi-nreci-kexti 399 DO jl = 1, ipreci 400 r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 401 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 402 END DO 403 END SELECT 404 ! 405 ! ! Migrations 406 imigr = ipreci * ( jpj + 2*kextj ) 407 ! 408 IF( ln_timing ) CALL tic_tac(.TRUE.) 409 ! 410 SELECT CASE ( nbondi ) 411 CASE ( -1 ) 412 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 413 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 414 CALL mpi_wait(ml_req1,ml_stat,ml_err) 415 CASE ( 0 ) 416 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 417 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 418 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 419 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 420 CALL mpi_wait(ml_req1,ml_stat,ml_err) 421 CALL mpi_wait(ml_req2,ml_stat,ml_err) 422 CASE ( 1 ) 423 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 424 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 425 CALL mpi_wait(ml_req1,ml_stat,ml_err) 426 END SELECT 427 ! 428 IF( ln_timing ) CALL tic_tac(.FALSE.) 429 ! 430 ! ! Write Dirichlet lateral conditions 431 iihom = jpi - nn_hls 432 ! 433 SELECT CASE ( nbondi ) 434 CASE ( -1 ) 435 DO jl = 1, ipreci 436 pt2d(iihom+jl,:) = r2dew(:,jl,2) 437 END DO 438 CASE ( 0 ) 439 DO jl = 1, ipreci 440 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 441 pt2d(iihom+jl,:) = r2dew(:,jl,2) 442 END DO 443 CASE ( 1 ) 444 DO jl = 1, ipreci 445 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 446 END DO 447 END SELECT 448 449 450 ! 3. North and south directions 451 ! ----------------------------- 452 ! always closed : we play only with the neigbours 453 ! 454 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 455 ijhom = jpj-nrecj-kextj 456 DO jl = 1, iprecj 457 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 458 r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 459 END DO 460 ENDIF 461 ! 462 ! ! Migrations 463 imigr = iprecj * ( jpi + 2*kexti ) 464 ! 465 IF( ln_timing ) CALL tic_tac(.TRUE.) 466 ! 467 SELECT CASE ( nbondj ) 468 CASE ( -1 ) 469 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 470 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 471 CALL mpi_wait(ml_req1,ml_stat,ml_err) 472 CASE ( 0 ) 473 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 474 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 475 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 476 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 477 CALL mpi_wait(ml_req1,ml_stat,ml_err) 478 CALL mpi_wait(ml_req2,ml_stat,ml_err) 479 CASE ( 1 ) 480 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 481 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 482 CALL mpi_wait(ml_req1,ml_stat,ml_err) 483 END SELECT 484 ! 485 IF( ln_timing ) CALL tic_tac(.FALSE.) 486 ! 487 ! ! Write Dirichlet lateral conditions 488 ijhom = jpj - nn_hls 489 ! 490 SELECT CASE ( nbondj ) 491 CASE ( -1 ) 492 DO jl = 1, iprecj 493 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 494 END DO 495 CASE ( 0 ) 496 DO jl = 1, iprecj 497 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 498 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 499 END DO 500 CASE ( 1 ) 501 DO jl = 1, iprecj 502 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 503 END DO 504 END SELECT 505 ! 506 END SUBROUTINE mpp_lnk_2d_icb 507 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 508 410 END MODULE lbclnk 509 411 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lbcnfd.F90
r11536 r13228 26 26 27 27 INTERFACE lbc_nfd 28 MODULE PROCEDURE lbc_nfd_2d , lbc_nfd_3d , lbc_nfd_4d 29 MODULE PROCEDURE lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 30 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 31 34 END INTERFACE 32 35 ! 33 36 INTERFACE lbc_nfd_nogather 34 37 ! ! Currently only 4d array version is needed 35 MODULE PROCEDURE lbc_nfd_nogather_2d , lbc_nfd_nogather_3d 36 MODULE PROCEDURE lbc_nfd_nogather_4d 37 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 38 44 ! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr 39 45 END INTERFACE 40 46 41 TYPE, PUBLIC :: PTR_2D !: array of 2D pointers (also used in lib_mpp) 42 REAL(wp), DIMENSION (:,:) , POINTER :: pt2d 43 END TYPE PTR_2D 44 TYPE, PUBLIC :: PTR_3D !: array of 3D pointers (also used in lib_mpp) 45 REAL(wp), DIMENSION (:,:,:) , POINTER :: pt3d 46 END TYPE PTR_3D 47 TYPE, PUBLIC :: PTR_4D !: array of 4D pointers (also used in lib_mpp) 48 REAL(wp), DIMENSION (:,:,:,:), POINTER :: pt4d 49 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 50 67 51 68 PUBLIC lbc_nfd ! north fold conditions … … 75 92 !!---------------------------------------------------------------------- 76 93 ! 77 ! !== 2D array and array of 2D pointer ==! 78 ! 79 # define DIM_2d 80 # define ROUTINE_NFD lbc_nfd_2d 81 # include "lbc_nfd_generic.h90" 82 # undef ROUTINE_NFD 83 # define MULTI 84 # define ROUTINE_NFD lbc_nfd_2d_ptr 94 ! !== SINGLE PRECISION VERSIONS 95 ! 96 ! 97 ! !== 2D array and array of 2D pointer ==! 98 ! 99 # define SINGLE_PRECISION 100 # define DIM_2d 101 # define ROUTINE_NFD lbc_nfd_2d_sp 102 # include "lbc_nfd_generic.h90" 103 # undef ROUTINE_NFD 104 # define MULTI 105 # define ROUTINE_NFD lbc_nfd_2d_ptr_sp 85 106 # include "lbc_nfd_generic.h90" 86 107 # undef ROUTINE_NFD … … 91 112 ! 92 113 # define DIM_2d 93 # define ROUTINE_NFD lbc_nfd_2d_ext 114 # define ROUTINE_NFD lbc_nfd_2d_ext_sp 94 115 # include "lbc_nfd_ext_generic.h90" 95 116 # undef ROUTINE_NFD … … 99 120 ! 100 121 # define DIM_3d 101 # define ROUTINE_NFD lbc_nfd_3d 102 # include "lbc_nfd_generic.h90" 103 # undef ROUTINE_NFD 104 # define MULTI 105 # define ROUTINE_NFD lbc_nfd_3d_ptr 106 # include "lbc_nfd_generic.h90" 107 # undef ROUTINE_NFD 108 # undef MULTI 109 # undef DIM_3d 110 ! 111 ! !== 4D array and array of 4D pointer ==! 112 ! 113 # define DIM_4d 114 # define ROUTINE_NFD lbc_nfd_4d 115 # include "lbc_nfd_generic.h90" 116 # undef ROUTINE_NFD 117 # define MULTI 118 # define ROUTINE_NFD lbc_nfd_4d_ptr 122 # define ROUTINE_NFD lbc_nfd_3d_sp 123 # include "lbc_nfd_generic.h90" 124 # undef ROUTINE_NFD 125 # define MULTI 126 # define ROUTINE_NFD lbc_nfd_3d_ptr_sp 127 # include "lbc_nfd_generic.h90" 128 # undef ROUTINE_NFD 129 # undef MULTI 130 # undef DIM_3d 131 ! 132 ! !== 4D array and array of 4D pointer ==! 133 ! 134 # define DIM_4d 135 # define ROUTINE_NFD lbc_nfd_4d_sp 136 # include "lbc_nfd_generic.h90" 137 # undef ROUTINE_NFD 138 # define MULTI 139 # define ROUTINE_NFD lbc_nfd_4d_ptr_sp 119 140 # include "lbc_nfd_generic.h90" 120 141 # undef ROUTINE_NFD … … 127 148 ! 128 149 # define DIM_2d 129 # define ROUTINE_NFD lbc_nfd_nogather_2d 130 # include "lbc_nfd_nogather_generic.h90" 131 # undef ROUTINE_NFD 132 # define MULTI 133 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr 134 # include "lbc_nfd_nogather_generic.h90" 135 # undef ROUTINE_NFD 136 # undef MULTI 137 # undef DIM_2d 138 ! 139 ! !== 3D array and array of 3D pointer ==! 140 ! 141 # define DIM_3d 142 # define ROUTINE_NFD lbc_nfd_nogather_3d 143 # include "lbc_nfd_nogather_generic.h90" 144 # undef ROUTINE_NFD 145 # define MULTI 146 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr 147 # include "lbc_nfd_nogather_generic.h90" 148 # undef ROUTINE_NFD 149 # undef MULTI 150 # undef DIM_3d 151 ! 152 ! !== 4D array and array of 4D pointer ==! 153 ! 154 # define DIM_4d 155 # define ROUTINE_NFD lbc_nfd_nogather_4d 150 # define ROUTINE_NFD lbc_nfd_nogather_2d_sp 151 # include "lbc_nfd_nogather_generic.h90" 152 # undef ROUTINE_NFD 153 # define MULTI 154 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_sp 155 # include "lbc_nfd_nogather_generic.h90" 156 # undef ROUTINE_NFD 157 # undef MULTI 158 # undef DIM_2d 159 ! 160 ! !== 3D array and array of 3D pointer ==! 161 ! 162 # define DIM_3d 163 # define ROUTINE_NFD lbc_nfd_nogather_3d_sp 164 # include "lbc_nfd_nogather_generic.h90" 165 # undef ROUTINE_NFD 166 # define MULTI 167 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_sp 168 # include "lbc_nfd_nogather_generic.h90" 169 # undef ROUTINE_NFD 170 # undef MULTI 171 # undef DIM_3d 172 ! 173 ! !== 4D array and array of 4D pointer ==! 174 ! 175 # define DIM_4d 176 # define ROUTINE_NFD lbc_nfd_nogather_4d_sp 156 177 # include "lbc_nfd_nogather_generic.h90" 157 178 # undef ROUTINE_NFD … … 162 183 !# undef MULTI 163 184 # undef DIM_4d 164 165 !!---------------------------------------------------------------------- 185 # undef SINGLE_PRECISION 186 187 !!---------------------------------------------------------------------- 188 ! 189 ! !== DOUBLE PRECISION VERSIONS 190 ! 191 ! 192 ! !== 2D array and array of 2D pointer ==! 193 ! 194 # define DIM_2d 195 # define ROUTINE_NFD lbc_nfd_2d_dp 196 # include "lbc_nfd_generic.h90" 197 # undef ROUTINE_NFD 198 # define MULTI 199 # define ROUTINE_NFD lbc_nfd_2d_ptr_dp 200 # include "lbc_nfd_generic.h90" 201 # undef ROUTINE_NFD 202 # undef MULTI 203 # undef DIM_2d 204 ! 205 ! !== 2D array with extra haloes ==! 206 ! 207 # define DIM_2d 208 # define ROUTINE_NFD lbc_nfd_2d_ext_dp 209 # include "lbc_nfd_ext_generic.h90" 210 # undef ROUTINE_NFD 211 # undef DIM_2d 212 ! 213 ! !== 3D array and array of 3D pointer ==! 214 ! 215 # define DIM_3d 216 # define ROUTINE_NFD lbc_nfd_3d_dp 217 # include "lbc_nfd_generic.h90" 218 # undef ROUTINE_NFD 219 # define MULTI 220 # define ROUTINE_NFD lbc_nfd_3d_ptr_dp 221 # include "lbc_nfd_generic.h90" 222 # undef ROUTINE_NFD 223 # undef MULTI 224 # undef DIM_3d 225 ! 226 ! !== 4D array and array of 4D pointer ==! 227 ! 228 # define DIM_4d 229 # define ROUTINE_NFD lbc_nfd_4d_dp 230 # include "lbc_nfd_generic.h90" 231 # undef ROUTINE_NFD 232 # define MULTI 233 # define ROUTINE_NFD lbc_nfd_4d_ptr_dp 234 # include "lbc_nfd_generic.h90" 235 # undef ROUTINE_NFD 236 # undef MULTI 237 # undef DIM_4d 238 ! 239 ! lbc_nfd_nogather routines 240 ! 241 ! !== 2D array and array of 2D pointer ==! 242 ! 243 # define DIM_2d 244 # define ROUTINE_NFD lbc_nfd_nogather_2d_dp 245 # include "lbc_nfd_nogather_generic.h90" 246 # undef ROUTINE_NFD 247 # define MULTI 248 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_dp 249 # include "lbc_nfd_nogather_generic.h90" 250 # undef ROUTINE_NFD 251 # undef MULTI 252 # undef DIM_2d 253 ! 254 ! !== 3D array and array of 3D pointer ==! 255 ! 256 # define DIM_3d 257 # define ROUTINE_NFD lbc_nfd_nogather_3d_dp 258 # include "lbc_nfd_nogather_generic.h90" 259 # undef ROUTINE_NFD 260 # define MULTI 261 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_dp 262 # include "lbc_nfd_nogather_generic.h90" 263 # undef ROUTINE_NFD 264 # undef MULTI 265 # undef DIM_3d 266 ! 267 ! !== 4D array and array of 4D pointer ==! 268 ! 269 # define DIM_4d 270 # define ROUTINE_NFD lbc_nfd_nogather_4d_dp 271 # include "lbc_nfd_nogather_generic.h90" 272 # undef ROUTINE_NFD 273 !# define MULTI 274 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr 275 !# include "lbc_nfd_nogather_generic.h90" 276 !# undef ROUTINE_NFD 277 !# undef MULTI 278 # undef DIM_4d 279 280 !!---------------------------------------------------------------------- 281 166 282 167 283 -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lib_mpp.F90
r13219 r13228 67 67 PUBLIC mpp_ini_znl 68 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 69 71 PUBLIC mpp_report 70 72 PUBLIC mpp_bcast_nml … … 79 81 !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ 80 82 INTERFACE mpp_min 81 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 82 86 END INTERFACE 83 87 INTERFACE mpp_max 84 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 85 91 END INTERFACE 86 92 INTERFACE mpp_sum 87 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 88 & 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 89 97 END INTERFACE 90 98 INTERFACE mpp_minloc 91 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 99 MODULE PROCEDURE mpp_minloc2d_sp ,mpp_minloc3d_sp 100 MODULE PROCEDURE mpp_minloc2d_dp ,mpp_minloc3d_dp 92 101 END INTERFACE 93 102 INTERFACE mpp_maxloc 94 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 103 MODULE PROCEDURE mpp_maxloc2d_sp ,mpp_maxloc3d_sp 104 MODULE PROCEDURE mpp_maxloc2d_dp ,mpp_maxloc3d_dp 95 105 END INTERFACE 96 106 … … 158 168 TYPE, PUBLIC :: DELAYARR 159 169 REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL() 160 COMPLEX( wp), POINTER, DIMENSION(:) :: y1d => NULL()170 COMPLEX(dp), POINTER, DIMENSION(:) :: y1d => NULL() 161 171 END TYPE DELAYARR 162 172 TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE :: todelay !: must have SAVE for default initialization of DELAYARR … … 164 174 165 175 ! timing summary report 166 REAL( wp), DIMENSION(2), PUBLIC :: waiting_time = 0._wp167 REAL( wp) , PUBLIC :: compute_time = 0._wp, elapsed_time = 0._wp176 REAL(dp), DIMENSION(2), PUBLIC :: waiting_time = 0._dp 177 REAL(dp) , PUBLIC :: compute_time = 0._dp, elapsed_time = 0._dp 168 178 169 179 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend … … 251 261 !! 252 262 INTEGER :: iflag 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 274 ! 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 253 292 !!---------------------------------------------------------------------- 254 293 ! … … 257 296 #endif 258 297 ! 259 END SUBROUTINE mppsend 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 260 322 261 323 … … 275 337 INTEGER :: iflag 276 338 INTEGER :: use_source 339 INTEGER :: mpi_working_type 277 340 !!---------------------------------------------------------------------- 278 341 ! … … 283 346 IF( PRESENT(ksource) ) use_source = ksource 284 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 ! 285 381 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 286 382 #endif 287 383 ! 288 END SUBROUTINE mpprecv 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 289 414 290 415 … … 351 476 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 352 477 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 353 COMPLEX( wp), INTENT(in ), DIMENSION(:) :: y_in478 COMPLEX(dp), INTENT(in ), DIMENSION(:) :: y_in 354 479 REAL(wp), INTENT( out), DIMENSION(:) :: pout 355 480 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine … … 359 484 INTEGER :: idvar 360 485 INTEGER :: ierr, ilocalcomm 361 COMPLEX( wp), ALLOCATABLE, DIMENSION(:) :: ytmp486 COMPLEX(dp), ALLOCATABLE, DIMENSION(:) :: ytmp 362 487 !!---------------------------------------------------------------------- 363 488 #if defined key_mpp_mpi … … 432 557 INTEGER :: idvar 433 558 INTEGER :: ierr, ilocalcomm 434 !!---------------------------------------------------------------------- 435 #if defined key_mpp_mpi 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 436 572 ilocalcomm = mpi_comm_oce 437 573 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 470 606 # if defined key_mpi2 471 607 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 472 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) 473 ndelayid(idvar) = 1 608 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 474 609 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 475 610 # else 476 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_ DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr )611 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 477 612 # endif 478 613 #else … … 551 686 # undef INTEGER_TYPE 552 687 ! 688 !! 689 !! ---- SINGLE PRECISION VERSIONS 690 !! 691 # define SINGLE_PRECISION 553 692 # define REAL_TYPE 554 693 # define DIM_0d 555 # define ROUTINE_ALLREDUCE mppmax_real 694 # define ROUTINE_ALLREDUCE mppmax_real_sp 556 695 # include "mpp_allreduce_generic.h90" 557 696 # undef ROUTINE_ALLREDUCE 558 697 # undef DIM_0d 559 698 # define DIM_1d 560 # 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 561 716 # include "mpp_allreduce_generic.h90" 562 717 # undef ROUTINE_ALLREDUCE … … 583 738 # undef INTEGER_TYPE 584 739 ! 740 !! 741 !! ---- SINGLE PRECISION VERSIONS 742 !! 743 # define SINGLE_PRECISION 585 744 # define REAL_TYPE 586 745 # define DIM_0d 587 # define ROUTINE_ALLREDUCE mppmin_real 746 # define ROUTINE_ALLREDUCE mppmin_real_sp 588 747 # include "mpp_allreduce_generic.h90" 589 748 # undef ROUTINE_ALLREDUCE 590 749 # undef DIM_0d 591 750 # define DIM_1d 592 # 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 593 767 # include "mpp_allreduce_generic.h90" 594 768 # undef ROUTINE_ALLREDUCE … … 616 790 # undef DIM_1d 617 791 # undef INTEGER_TYPE 618 ! 792 793 !! 794 !! ---- SINGLE PRECISION VERSIONS 795 !! 796 # define OPERATION_SUM 797 # define SINGLE_PRECISION 619 798 # define REAL_TYPE 620 799 # define DIM_0d 621 # define ROUTINE_ALLREDUCE mppsum_real 800 # define ROUTINE_ALLREDUCE mppsum_real_sp 622 801 # include "mpp_allreduce_generic.h90" 623 802 # undef ROUTINE_ALLREDUCE 624 803 # undef DIM_0d 625 804 # define DIM_1d 626 # 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 627 826 # include "mpp_allreduce_generic.h90" 628 827 # undef ROUTINE_ALLREDUCE … … 651 850 !!---------------------------------------------------------------------- 652 851 !! 852 !! 853 !! ---- SINGLE PRECISION VERSIONS 854 !! 855 # define SINGLE_PRECISION 653 856 # define OPERATION_MINLOC 654 857 # define DIM_2d 655 # define ROUTINE_LOC mpp_minloc2d 858 # define ROUTINE_LOC mpp_minloc2d_sp 656 859 # include "mpp_loc_generic.h90" 657 860 # undef ROUTINE_LOC 658 861 # undef DIM_2d 659 862 # define DIM_3d 660 # define ROUTINE_LOC mpp_minloc3d 863 # define ROUTINE_LOC mpp_minloc3d_sp 661 864 # include "mpp_loc_generic.h90" 662 865 # undef ROUTINE_LOC … … 666 869 # define OPERATION_MAXLOC 667 870 # define DIM_2d 668 # define ROUTINE_LOC mpp_maxloc2d 871 # define ROUTINE_LOC mpp_maxloc2d_sp 669 872 # include "mpp_loc_generic.h90" 670 873 # undef ROUTINE_LOC 671 874 # undef DIM_2d 672 875 # define DIM_3d 673 # define ROUTINE_LOC mpp_maxloc3d 876 # define ROUTINE_LOC mpp_maxloc3d_sp 674 877 # include "mpp_loc_generic.h90" 675 878 # undef ROUTINE_LOC 676 879 # undef DIM_3d 677 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 678 911 679 912 SUBROUTINE mppsync() … … 904 1137 !!--------------------------------------------------------------------- 905 1138 INTEGER , INTENT(in) :: ilen, itype 906 COMPLEX( wp), DIMENSION(ilen), INTENT(in) :: ydda907 COMPLEX( wp), DIMENSION(ilen), INTENT(inout) :: yddb908 ! 909 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 910 1143 INTEGER :: ji, ztmp ! local scalar 911 1144 !!--------------------------------------------------------------------- … … 1060 1293 LOGICAL, INTENT(IN) :: ld_tic 1061 1294 LOGICAL, OPTIONAL, INTENT(IN) :: ld_global 1062 REAL( wp), DIMENSION(2), SAVE :: tic_wt1063 REAL( wp), SAVE :: tic_ct = 0._wp1295 REAL(dp), DIMENSION(2), SAVE :: tic_wt 1296 REAL(dp), SAVE :: tic_ct = 0._dp 1064 1297 INTEGER :: ii 1065 1298 #if defined key_mpp_mpi … … 1074 1307 IF ( ld_tic ) THEN 1075 1308 tic_wt(ii) = MPI_Wtime() ! start count tic->tac (waiting time) 1076 IF ( tic_ct > 0.0_ wp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic1309 IF ( tic_ct > 0.0_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic 1077 1310 ELSE 1078 1311 waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii) ! cumulate count tic->tac -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/mpp_allreduce_generic.h90
r10425 r13228 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 … … 75 81 END SUBROUTINE ROUTINE_ALLREDUCE 76 82 83 #undef PRECISION 77 84 #undef ARRAY_TYPE 78 85 #undef ARRAY_IN -
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/mpp_lnk_generic.h90
r11536 r13228 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 … … 44 60 # endif 45 61 #endif 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 46 72 47 73 #if defined MULTI … … 67 93 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 68 94 INTEGER :: ihl ! number of ranks and rows to be communicated 69 REAL( wp) :: zland95 REAL(PRECISION) :: zland 70 96 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 71 REAL( wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos72 REAL( wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos97 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos 98 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos 73 99 LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send 74 100 LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive … … 174 200 ! 175 201 ! non-blocking send of the western/eastern side using local temporary arrays