Changeset 13247
- Timestamp:
- 2020-07-03T19:15:31+02:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo
- Files:
-
- 122 edited
- 4 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/ABL/ablmod.F90
r13229 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icecor.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icedyn.F90
r12377 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icedyn_adv_pra.F90
r12738 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icedyn_adv_umx.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icedyn_rdgrft.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icedyn_rhg_evp.F90
r12738 r13247 299 299 300 300 END_2D 301 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1. , zdt_m, 'T', 1.)301 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp ) 302 302 ! 303 303 ! !== Landfast ice parameterization ==! … … 318 318 tau_icebfr(ji,jj) = - rn_icebfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 319 319 END_2D 320 CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1. )320 CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1.0_wp ) 321 321 ! 322 322 ELSE !-- no landfast … … 352 352 353 353 END_2D 354 CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1. )354 CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1.0_wp ) 355 355 356 356 DO_2D_01_01 … … 394 394 395 395 END_2D 396 CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1. )396 CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1.0_wp ) 397 397 398 398 DO_2D_10_10 … … 483 483 ENDIF 484 484 END_2D 485 CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. )485 CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1.0_wp ) 486 486 ! 487 487 #if defined key_agrif … … 532 532 ENDIF 533 533 END_2D 534 CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. )534 CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp ) 535 535 ! 536 536 #if defined key_agrif … … 583 583 ENDIF 584 584 END_2D 585 CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. )585 CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp ) 586 586 ! 587 587 #if defined key_agrif … … 632 632 ENDIF 633 633 END_2D 634 CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. )634 CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1.0_wp ) 635 635 ! 636 636 #if defined key_agrif … … 693 693 694 694 END_2D 695 CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1. , pdivu_i, 'T', 1., pdelta_i, 'T', 1.)695 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 ) 696 696 697 697 ! --- Store the stress tensor for the next time step --- ! 698 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zs1, 'T', 1. , zs2, 'T', 1., zs12, 'F', 1.)698 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zs1, 'T', 1.0_wp, zs2, 'T', 1.0_wp, zs12, 'F', 1.0_wp ) 699 699 pstress1_i (:,:) = zs1 (:,:) 700 700 pstress2_i (:,:) = zs2 (:,:) … … 713 713 & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN 714 714 ! 715 CALL lbc_lnk_multi( 'icedyn_rhg_evp', ztaux_oi, 'U', -1. , ztauy_oi, 'V', -1., ztaux_ai, 'U', -1., ztauy_ai, 'V', -1., &716 & ztaux_bi, 'U', -1. , ztauy_bi, 'V', -1.)715 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, & 716 & ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 717 717 ! 718 718 CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) … … 751 751 zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) 752 752 END_2D 753 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1. , zsig2, 'T', 1., zsig3, 'T', 1.)753 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1.0_wp, zsig2, 'T', 1.0_wp, zsig3, 'T', 1.0_wp ) 754 754 ! 755 755 CALL iom_put( 'isig1' , zsig1 ) … … 768 768 & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN 769 769 ! 770 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zspgU, 'U', -1. , zspgV, 'V', -1., &771 & zCorU, 'U', -1. , zCorV, 'V', -1., zfU, 'U', -1., zfV, 'V', -1.)770 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, & 771 & zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp ) 772 772 773 773 CALL iom_put( 'dssh_dx' , zspgU * zmsk00 ) ! Sea-surface tilt term in force balance (x) … … 801 801 END_2D 802 802 803 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1. , zdiag_ymtrp_ice, 'V', -1., &804 & zdiag_xmtrp_snw, 'U', -1. , zdiag_ymtrp_snw, 'V', -1., &805 & zdiag_xatrp , 'U', -1. , zdiag_yatrp , 'V', -1.)803 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, & 804 & zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, & 805 & zdiag_xatrp , 'U', -1.0_wp, zdiag_yatrp , 'V', -1.0_wp ) 806 806 807 807 CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/ICE/iceitd.F90
r12377 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icesbc.F90
r12377 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icethd.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icethd_dh.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icethd_do.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icethd_ent.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/iceupdate.F90
r12738 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icevar.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/ICE/icewri.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/NST/agrif_user.F90
r13238 r13247 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 … … 635 635 USE Agrif_Util 636 636 USE ice 637 USE par_oce 637 638 ! 638 639 IMPLICIT NONE -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/ASM/asminc.F90
r12939 r13247 419 419 & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk) ) / e3t(ji,jj,jk,Kmm) 420 420 END_2D 421 CALL lbc_lnk( 'asminc', zhdiv, 'T', 1. ) ! lateral boundary cond. (no sign change)421 CALL lbc_lnk( 'asminc', zhdiv, 'T', 1.0_wp ) ! lateral boundary cond. (no sign change) 422 422 ! 423 423 DO_2D_00_00 -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/BDY/bdydyn2d.F90
r11536 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/BDY/bdydyn3d.F90
r12377 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/BDY/bdyice.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/BDY/bdyini.F90
r12939 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/BDY/bdylib.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/BDY/bdytra.F90
r12377 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/CRS/crsdom.F90
r12807 r13247 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 … … 2242 2242 2243 2243 zmbk(:,:) = 0.0 2244 zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0 ) ; mbathy_crs(:,:) = NINT( zmbk(:,:) )2244 zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0_wp) ; mbathy_crs(:,:) = NINT( zmbk(:,:) ) 2245 2245 2246 2246 … … 2262 2262 ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 2263 2263 zmbk(:,:) = 1.e0; 2264 zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0 ) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 )2265 zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0 ) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 )2264 zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0_wp) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) 2265 zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0_wp) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) 2266 2266 ! 2267 2267 END SUBROUTINE crs_dom_bat -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/CRS/crsdomwri.F90
r12807 r13247 131 131 END DO 132 132 END DO 133 CALL crs_lbc_lnk( zdepu,'U', 1. ) ; CALL crs_lbc_lnk( zdepv,'V', 1.)133 CALL crs_lbc_lnk( zdepu,'U', 1.0_wp ) ; CALL crs_lbc_lnk( zdepv,'V', 1.0_wp ) 134 134 ! 135 135 CALL iom_rstput( 0, 0, inum, 'gdepu', zdepu, ktype = jp_r4 ) … … 191 191 ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi_crs*jpj_crs) /), (/ jpi_crs, jpj_crs /) ) 192 192 ! 193 puniq(:,:) = ztstref(:,:) 194 CALL crs_lbc_lnk( puniq,cdgrd, 1. )! apply boundary conditions193 puniq(:,:) = ztstref(:,:) ! default definition 194 CALL crs_lbc_lnk( puniq,cdgrd, 1.0_wp ) ! apply boundary conditions 195 195 lluniq(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed 196 196 ! -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/CRS/crsfld.F90
r12377 r13247 98 98 ! Temperature 99 99 zt(:,:,:) = ts(:,:,:,jp_tem,Kmm) ; zt_crs(:,:,:) = 0._wp 100 CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 )100 CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) 101 101 tsn_crs(:,:,:,jp_tem) = zt_crs(:,:,:) 102 102 … … 107 107 ! Salinity 108 108 zs(:,:,:) = ts(:,:,:,jp_sal,Kmm) ; zs_crs(:,:,:) = 0._wp 109 CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 )109 CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) 110 110 tsn_crs(:,:,:,jp_sal) = zt_crs(:,:,:) 111 111 … … 114 114 115 115 ! U-velocity 116 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 )116 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 ) 117 117 ! 118 118 zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp … … 121 121 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) ) 122 122 END_3D 123 CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )124 CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )123 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 ) 124 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 ) 125 125 126 126 CALL iom_put( "uoce" , un_crs ) ! i-current … … 129 129 130 130 ! V-velocity 131 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 )131 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 ) 132 132 ! 133 133 zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp … … 136 136 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) ) 137 137 END_3D 138 CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )139 CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )138 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 ) 139 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 ) 140 140 141 141 CALL iom_put( "voce" , vn_crs ) ! i-current … … 153 153 & + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) ) 154 154 END_3D 155 CALL lbc_lnk( 'crsfld', z3d, 'T', 1. )155 CALL lbc_lnk( 'crsfld', z3d, 'T', 1.0_wp ) 156 156 ! 157 CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 )157 CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) 158 158 CALL iom_put( "eken", zt_crs ) 159 159 ENDIF … … 173 173 END DO 174 174 END DO 175 CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0 )175 CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0_wp ) 176 176 ! 177 177 CALL iom_put( "hdiv", hdivn_crs ) … … 180 180 ! W-velocity 181 181 IF( ln_crs_wn ) THEN 182 CALL crs_dom_ope( ww, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0 )182 CALL crs_dom_ope( ww, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0_wp ) 183 183 ! CALL crs_dom_ope( ww, 'VOL', 'W', tmask, wn_crs, p_e12=e1e2t, p_e3=ze3w ) 184 184 ELSE … … 194 194 SELECT CASE ( nn_crs_kz ) 195 195 CASE ( 0 ) 196 CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )197 CALL crs_dom_ope( avs, 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )196 CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 197 CALL crs_dom_ope( avs, 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 198 198 CASE ( 1 ) 199 CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )200 CALL crs_dom_ope( avs, 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )199 CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 200 CALL crs_dom_ope( avs, 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 201 201 CASE ( 2 ) 202 CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )203 CALL crs_dom_ope( avs, 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 )202 CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 203 CALL crs_dom_ope( avs, 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 204 204 END SELECT 205 205 ! … … 208 208 209 209 ! sbc fields 210 CALL crs_dom_ope( ssh(:,:,Kmm) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0 )211 CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u , p_surf_crs=e2u_crs , psgn=1.0 )212 CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v , p_surf_crs=e1v_crs , psgn=1.0 )213 CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )214 CALL crs_dom_ope( rnf , 'MAX', 'T', tmask, rnf_crs , psgn=1.0 )215 CALL crs_dom_ope( qsr , 'SUM', 'T', tmask, qsr_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )216 CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )217 CALL crs_dom_ope( emp , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )218 CALL crs_dom_ope( sfx , 'SUM', 'T', tmask, sfx_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )219 CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 )210 CALL crs_dom_ope( ssh(:,:,Kmm) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0_wp ) 211 CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u , p_surf_crs=e2u_crs , psgn=1.0_wp ) 212 CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v , p_surf_crs=e1v_crs , psgn=1.0_wp ) 213 CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 214 CALL crs_dom_ope( rnf , 'MAX', 'T', tmask, rnf_crs , psgn=1.0_wp ) 215 CALL crs_dom_ope( qsr , 'SUM', 'T', tmask, qsr_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 216 CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 217 CALL crs_dom_ope( emp , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 218 CALL crs_dom_ope( sfx , 'SUM', 'T', tmask, sfx_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 219 CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 220 220 221 221 CALL iom_put( "ssh" , sshn_crs ) ! ssh output -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/CRS/crsini.F90
r12377 r13247 207 207 208 208 ! 3.d.3 Vertical depth (meters) 209 CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0 )210 CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0 )209 CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0_wp ) 210 CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0_wp ) 211 211 212 212 -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DIA/diaar5.F90
r13124 r13247 317 317 z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk) 318 318 END_3D 319 CALL lbc_lnk( 'diaar5', z2d, 'U', -1. )319 CALL lbc_lnk( 'diaar5', z2d, 'U', -1.0_wp ) 320 320 IF( cptr == 'adv' ) THEN 321 321 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in i-direction … … 331 331 z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk) 332 332 END_3D 333 CALL lbc_lnk( 'diaar5', z2d, 'V', -1. )333 CALL lbc_lnk( 'diaar5', z2d, 'V', -1.0_wp ) 334 334 IF( cptr == 'adv' ) THEN 335 335 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in j-direction -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DIA/diaptr.F90
r12738 r13247 568 568 p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 569 569 END_2D 570 CALL lbc_lnk( 'diaptr', p_fval, 'U', -1. )570 CALL lbc_lnk( 'diaptr', p_fval, 'U', -1.0_wp ) 571 571 END DO 572 572 ! -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DIA/diawri.F90
r13130 r13247 185 185 ! 186 186 END_2D 187 CALL lbc_lnk( 'diawri', z2d, 'T', 1. )187 CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp ) 188 188 CALL iom_put( "taubot", z2d ) 189 189 ENDIF … … 239 239 & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) 240 240 END_2D 241 CALL lbc_lnk( 'diawri', z2d, 'T', 1. )241 CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp ) 242 242 CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient 243 243 z2d(:,:) = SQRT( z2d(:,:) ) … … 271 271 & + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) ) 272 272 END_3D 273 CALL lbc_lnk( 'diawri', z3d, 'T', 1. )273 CALL lbc_lnk( 'diawri', z3d, 'T', 1.0_wp ) 274 274 CALL iom_put( "eken", z3d ) ! kinetic energy 275 275 ENDIF … … 293 293 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) ) 294 294 END_3D 295 CALL lbc_lnk( 'diawri', z2d, 'U', -1. )295 CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp ) 296 296 CALL iom_put( "u_heattr", 0.5*rcp * z2d ) ! heat transport in i-direction 297 297 ENDIF … … 302 302 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) ) 303 303 END_3D 304 CALL lbc_lnk( 'diawri', z2d, 'U', -1. )304 CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp ) 305 305 CALL iom_put( "u_salttr", 0.5 * z2d ) ! heat transport in i-direction 306 306 ENDIF … … 320 320 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) ) 321 321 END_3D 322 CALL lbc_lnk( 'diawri', z2d, 'V', -1. )322 CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp ) 323 323 CALL iom_put( "v_heattr", 0.5*rcp * z2d ) ! heat transport in j-direction 324 324 ENDIF … … 329 329 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) ) 330 330 END_3D 331 CALL lbc_lnk( 'diawri', z2d, 'V', -1. )331 CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp ) 332 332 CALL iom_put( "v_salttr", 0.5 * z2d ) ! heat transport in j-direction 333 333 ENDIF … … 338 338 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) 339 339 END_3D 340 CALL lbc_lnk( 'diawri', z2d, 'T', -1. )340 CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp ) 341 341 CALL iom_put( "tosmint", rho0 * z2d ) ! Vertical integral of temperature 342 342 ENDIF … … 346 346 z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) 347 347 END_3D 348 CALL lbc_lnk( 'diawri', z2d, 'T', -1. )348 CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp ) 349 349 CALL iom_put( "somint", rho0 * z2d ) ! Vertical integral of salinity 350 350 ENDIF -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DOM/daymod.F90
r13176 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/DOM/dommsk.F90
r13138 r13247 162 162 & * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk) 163 163 END_3D 164 CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1. , vmask, 'V', 1., fmask, 'F', 1.) ! Lateral boundary conditions164 CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1.0_wp, vmask, 'V', 1.0_wp, fmask, 'F', 1.0_wp ) ! Lateral boundary conditions 165 165 166 166 ! Ocean/land mask at wu-, wv- and w points (computed from tmask) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DOM/domwri.F90
r13130 r13247 229 229 END DO 230 230 END DO 231 CALL lbc_lnk( 'domwri', zx1, 'T', 1. )231 CALL lbc_lnk( 'domwri', zx1, 'T', 1.0_wp ) 232 232 ! 233 233 IF( PRESENT( px1 ) ) px1 = zx1 -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DOM/domzgr.F90
r13176 r13247 340 340 END_2D 341 341 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 342 zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 )343 zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 )344 zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1. ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 )345 ! 346 zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 )347 zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 )342 zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) 343 zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) 344 zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) 345 ! 346 zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) 347 zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) 348 348 ! 349 349 END SUBROUTINE zgr_top_bot -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DYN/divhor.F90
r12980 r13247 93 93 IF( ln_isf ) CALL isf_hdiv( kt, Kmm, hdiv ) !== ice shelf ==! (update hdiv field) 94 94 ! 95 CALL lbc_lnk( 'divhor', hdiv, 'T', 1. ) ! (no sign change)95 CALL lbc_lnk( 'divhor', hdiv, 'T', 1.0_wp ) ! (no sign change) 96 96 ! 97 97 IF( ln_timing ) CALL timing_stop('div_hor') -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DYN/dynadv_ubs.F90
r12377 r13247 123 123 END_2D 124 124 END DO 125 CALL lbc_lnk_multi( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', 1. , zlu_uv(:,:,:,1), 'U', 1., &126 & zlu_uu(:,:,:,2), 'U', 1. , zlu_uv(:,:,:,2), 'U', 1., &127 & zlv_vv(:,:,:,1), 'V', 1. , zlv_vu(:,:,:,1), 'V', 1., &128 & zlv_vv(:,:,:,2), 'V', 1. , zlv_vu(:,:,:,2), 'V', 1.)125 CALL lbc_lnk_multi( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', 1.0_wp , zlu_uv(:,:,:,1), 'U', 1.0_wp, & 126 & zlu_uu(:,:,:,2), 'U', 1.0_wp , zlu_uv(:,:,:,2), 'U', 1.0_wp, & 127 & zlv_vv(:,:,:,1), 'V', 1.0_wp , zlv_vu(:,:,:,1), 'V', 1.0_wp, & 128 & zlv_vv(:,:,:,2), 'V', 1.0_wp , zlv_vu(:,:,:,2), 'V', 1.0_wp ) 129 129 ! 130 130 ! ! ====================== ! -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DYN/dynatf.F90
r12489 r13247 148 148 # endif 149 149 ! 150 CALL lbc_lnk_multi( 'dynatf', puu(:,:,:,Kaa), 'U', -1. , pvv(:,:,:,Kaa), 'V', -1.) !* local domain boundaries150 CALL lbc_lnk_multi( 'dynatf', puu(:,:,:,Kaa), 'U', -1.0_wp, pvv(:,:,:,Kaa), 'V', -1.0_wp ) !* local domain boundaries 151 151 ! 152 152 ! !* BDY open boundaries -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DYN/dynhpg.F90
r12377 r13247 446 446 END IF 447 447 END_2D 448 CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1. , zcpy, 'V', 1.)448 CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 449 449 END IF 450 450 … … 669 669 END IF 670 670 END_2D 671 CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1. , zcpy, 'V', 1.)671 CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 672 672 END IF 673 673 … … 815 815 816 816 END_3D 817 CALL lbc_lnk_multi( 'dynhpg', rho_k, 'W', 1. , rho_i, 'U', 1., rho_j, 'V', 1.)817 CALL lbc_lnk_multi( 'dynhpg', rho_k, 'W', 1.0_wp, rho_i, 'U', 1.0_wp, rho_j, 'V', 1.0_wp ) 818 818 819 819 ! --------------- … … 942 942 ENDIF 943 943 END_2D 944 CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1. , zcpy, 'V', 1.)944 CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 945 945 ENDIF 946 946 … … 1012 1012 END_2D 1013 1013 1014 CALL lbc_lnk_multi ('dynhpg', zsshu_n, 'U', 1. , zsshv_n, 'V', 1.)1014 CALL lbc_lnk_multi ('dynhpg', zsshu_n, 'U', 1.0_wp, zsshv_n, 'V', 1.0_wp ) 1015 1015 1016 1016 DO_2D_00_00 -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DYN/dynkeg.F90
r12377 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/DYN/dynldf_iso.F90
r12377 r13247 134 134 END_3D 135 135 ! Lateral boundary conditions on the slopes 136 CALL lbc_lnk_multi( 'dynldf_iso', uslp , 'U', -1. , vslp , 'V', -1., wslpi, 'W', -1., wslpj, 'W', -1.)136 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 ) 137 137 ! 138 138 ENDIF -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DYN/dynldf_lap_blp.F90
r12807 r13247 131 131 CALL dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 ) ! rotated laplacian applied to pt (output in zlap,Kbb) 132 132 ! 133 CALL lbc_lnk_multi( 'dynldf_lap_blp', zulap, 'U', -1. , zvlap, 'V', -1.) ! Lateral boundary conditions133 CALL lbc_lnk_multi( 'dynldf_lap_blp', zulap, 'U', -1.0_wp, zvlap, 'V', -1.0_wp ) ! Lateral boundary conditions 134 134 ! 135 135 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/DYN/dynvor.F90
r13065 r13247 240 240 END DO 241 241 242 CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )242 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 243 243 244 244 CASE ( np_CRV ) !* Coriolis + relative vorticity … … 255 255 END DO 256 256 257 CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )257 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 258 258 259 259 END SELECT … … 600 600 END DO ! End of slab 601 601 ! 602 CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )602 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 603 603 604 604 DO jk = 1, jpkm1 ! Horizontal slab … … 721 721 END DO 722 722 ! 723 CALL lbc_lnk( 'dynvor', zwz, 'F', 1. )723 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 724 724 ! 725 725 DO jk = 1, jpkm1 ! Horizontal slab … … 851 851 dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji ,jj-1) ) * 0.5_wp 852 852 END_2D 853 CALL lbc_lnk_multi( 'dynvor', di_e2u_2, 'T', -1. , dj_e1v_2, 'T', -1.) ! Lateral boundary conditions853 CALL lbc_lnk_multi( 'dynvor', di_e2u_2, 'T', -1.0_wp , dj_e1v_2, 'T', -1.0_wp ) ! Lateral boundary conditions 854 854 ! 855 855 CASE DEFAULT !* F-point metric term : pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f) … … 859 859 dj_e1u_2e1e2f(ji,jj) = ( e1u(ji ,jj+1) - e1u(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj) 860 860 END_2D 861 CALL lbc_lnk_multi( 'dynvor', di_e2v_2e1e2f, 'F', -1. , dj_e1u_2e1e2f, 'F', -1.) ! Lateral boundary conditions861 CALL lbc_lnk_multi( 'dynvor', di_e2v_2e1e2f, 'F', -1.0_wp , dj_e1u_2e1e2f, 'F', -1.0_wp ) ! Lateral boundary conditions 862 862 END SELECT 863 863 ! -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DYN/sshwzv.F90
r13232 r13247 116 116 IF ( .NOT.ln_dynspg_ts ) THEN 117 117 IF( ln_bdy ) THEN 118 CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1. ) ! Not sure that's necessary118 CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1.0_wp ) ! Not sure that's necessary 119 119 CALL bdy_ssh( pssh(:,:,Kaa) ) ! Duplicate sea level across open boundaries 120 120 ENDIF … … 177 177 END_2D 178 178 END DO 179 CALL lbc_lnk('sshwzv', zhdiv, 'T', 1. ) ! - ML - Perhaps not necessary: not used for horizontal "connexions"179 CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.0_wp) ! - ML - Perhaps not necessary: not used for horizontal "connexions" 180 180 ! ! Is it problematic to have a wrong vertical velocity in boundary cells? 181 181 ! ! Same question holds for hdiv. Perhaps just for security … … 369 369 END_3D 370 370 ENDIF 371 CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1. )371 CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1.0_wp ) 372 372 ! 373 373 CALL iom_put("Courant",Cu_adv) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DYN/wet_dry.F90
r12489 r13247 241 241 ENDIF 242 242 END_2D 243 CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1. , zwdlmtv, 'V', 1.)243 CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) 244 244 ! 245 245 CALL mpp_max('wet_dry', jflag) !max over the global domain … … 257 257 ! 258 258 !!gm TO BE SUPPRESSED ? these lbc_lnk are useless since zwdlmtu and zwdlmtv are defined everywhere ! 259 CALL lbc_lnk_multi( 'wet_dry', puu(:,:,:,Kmm) , 'U', -1. , pvv(:,:,:,Kmm) , 'V', -1.)260 CALL lbc_lnk_multi( 'wet_dry', uu_b(:,:,Kmm), 'U', -1. , vv_b(:,:,Kmm), 'V', -1.)259 CALL lbc_lnk_multi( 'wet_dry', puu(:,:,:,Kmm) , 'U', -1.0_wp, pvv(:,:,:,Kmm) , 'V', -1.0_wp ) 260 CALL lbc_lnk_multi( 'wet_dry', uu_b(:,:,Kmm), 'U', -1.0_wp, vv_b(:,:,Kmm), 'V', -1.0_wp ) 261 261 !!gm 262 262 ! … … 366 366 END_2D 367 367 ! 368 CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1. , zwdlmtv, 'V', 1.)368 CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) 369 369 ! 370 370 CALL mpp_max('wet_dry', jflag) !max over the global domain … … 378 378 ! 379 379 !!gm THIS lbc_lnk is useless since it is already done at the end of the jk1-loop 380 CALL lbc_lnk_multi( 'wet_dry', zflxu, 'U', -1. , zflxv, 'V', -1.)380 CALL lbc_lnk_multi( 'wet_dry', zflxu, 'U', -1.0_wp, zflxv, 'V', -1.0_wp ) 381 381 !!gm end 382 382 ! -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/ICB/icblbc.F90
r12377 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/ICB/icbthm.F90
r12291 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/IOM/iom.F90
r13229 r13247 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 … … 153 160 ! 154 161 IF( ln_cfmeta ) THEN ! Add additional grid metadata 155 CALL iom_set_domain_attr("grid_T", area = e1e2t(Nis0:Nie0, Njs0:Nje0))156 CALL iom_set_domain_attr("grid_U", area = e1e2u(Nis0:Nie0, Njs0:Nje0))157 CALL iom_set_domain_attr("grid_V", area = e1e2v(Nis0:Nie0, Njs0:Nje0))158 CALL iom_set_domain_attr("grid_W", area = e1e2t(Nis0:Nie0, Njs0:Nje0))162 CALL iom_set_domain_attr("grid_T", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 163 CALL iom_set_domain_attr("grid_U", area = real( e1e2u(Nis0:Nie0, Njs0:Nje0), dp)) 164 CALL iom_set_domain_attr("grid_V", area = real( e1e2v(Nis0:Nie0, Njs0:Nje0), dp)) 165 CALL iom_set_domain_attr("grid_W", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 159 166 CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 160 167 CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) … … 176 183 ! 177 184 IF( ln_cfmeta .AND. .NOT. llrst_context) THEN ! Add additional grid metadata 178 CALL iom_set_domain_attr("grid_T", area = e1e2t_crs(Nis0:Nie0, Njs0:Nje0))179 CALL iom_set_domain_attr("grid_U", area = e1u_crs(Nis0:Nie0, Njs0:Nje0) * e2u_crs(Nis0:Nie0, Njs0:Nje0))180 CALL iom_set_domain_attr("grid_V", area = e1v_crs(Nis0:Nie0, Njs0:Nje0) * e2v_crs(Nis0:Nie0, Njs0:Nje0))181 CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(Nis0:Nie0, Njs0:Nje0))185 CALL iom_set_domain_attr("grid_T", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp)) 186 CALL iom_set_domain_attr("grid_U", area = real(e1u_crs(Nis0:Nie0, Njs0:Nje0) * e2u_crs(Nis0:Nie0, Njs0:Nje0), dp)) 187 CALL iom_set_domain_attr("grid_V", area = real(e1v_crs(Nis0:Nie0, Njs0:Nje0) * e2v_crs(Nis0:Nie0, Njs0:Nje0), dp)) 188 CALL iom_set_domain_attr("grid_W", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp)) 182 189 CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 183 190 CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) … … 881 888 !! INTERFACE iom_get 882 889 !!---------------------------------------------------------------------- 883 SUBROUTINE iom_g0d ( kiomid, cdvar, pvar, ktime, ldxios )890 SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime, ldxios ) 884 891 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 885 892 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 886 REAL(wp) , INTENT( out) :: pvar ! read field 893 REAL(sp) , INTENT( out) :: pvar ! read field 894 REAL(dp) :: ztmp_pvar ! tmp var to read field 895 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 896 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart 897 ! 898 INTEGER :: idvar ! variable id 899 INTEGER :: idmspc ! number of spatial dimensions 900 INTEGER , DIMENSION(1) :: itime ! record number 901 CHARACTER(LEN=100) :: clinfo ! info character 902 CHARACTER(LEN=100) :: clname ! file name 903 CHARACTER(LEN=1) :: cldmspc ! 904 LOGICAL :: llxios 905 ! 906 llxios = .FALSE. 907 IF( PRESENT(ldxios) ) llxios = ldxios 908 909 IF(.NOT.llxios) THEN ! read data using default library 910 itime = 1 911 IF( PRESENT(ktime) ) itime = ktime 912 ! 913 clname = iom_file(kiomid)%name 914 clinfo = ' iom_g0d, file: '//trim(clname)//', var: '//trim(cdvar) 915 ! 916 IF( kiomid > 0 ) THEN 917 idvar = iom_varid( kiomid, cdvar ) 918 IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN 919 idmspc = iom_file ( kiomid )%ndims( idvar ) 920 IF( iom_file(kiomid)%luld(idvar) ) idmspc = idmspc - 1 921 WRITE(cldmspc , fmt='(i1)') idmspc 922 IF( idmspc > 0 ) CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', & 923 & 'with 1 or more spatial dimensions: '//cldmspc//' were found.' , & 924 & 'Use ncwa -a to suppress the unnecessary dimensions' ) 925 CALL iom_nf90_get( kiomid, idvar, ztmp_pvar, itime ) 926 pvar = ztmp_pvar 927 ENDIF 928 ENDIF 929 ELSE 930 #if defined key_iomput 931 IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 932 CALL iom_swap( TRIM(crxios_context) ) 933 CALL xios_recv_field( trim(cdvar), pvar) 934 CALL iom_swap( TRIM(cxios_context) ) 935 #else 936 WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) 937 CALL ctl_stop( 'iom_g0d', ctmp1 ) 938 #endif 939 ENDIF 940 END SUBROUTINE iom_g0d_sp 941 942 SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime, ldxios ) 943 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 944 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 945 REAL(dp) , INTENT( out) :: pvar ! read field 887 946 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 888 947 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart … … 929 988 #endif 930 989 ENDIF 931 END SUBROUTINE iom_g0d 932 933 SUBROUTINE iom_g1d ( kiomid, kdom, cdvar, pvar, ktime,kstart, kcount, ldxios )990 END SUBROUTINE iom_g0d_dp 991 992 SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 934 993 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 935 994 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 936 995 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 937 REAL(wp) , INTENT( out), DIMENSION(:) :: pvar ! read field 996 REAL(sp) , INTENT( out), DIMENSION(:) :: pvar ! read field 997 REAL(dp) , ALLOCATABLE , DIMENSION(:) :: ztmp_pvar ! tmp var to read field 938 998 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 939 999 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading … … 942 1002 ! 943 1003 IF( kiomid > 0 ) THEN 944 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & 945 & ktime=ktime , & 946 & kstart=kstart, kcount=kcount , ldxios=ldxios ) 947 ENDIF 948 END SUBROUTINE iom_g1d 949 950 SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios) 1004 IF( iom_file(kiomid)%nfid > 0 ) THEN 1005 ALLOCATE(ztmp_pvar(size(pvar,1))) 1006 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=ztmp_pvar, & 1007 & ktime=ktime, kstart=kstart, kcount=kcount, & 1008 & ldxios=ldxios ) 1009 pvar = ztmp_pvar 1010 DEALLOCATE(ztmp_pvar) 1011 END IF 1012 ENDIF 1013 END SUBROUTINE iom_g1d_sp 1014 1015 1016 SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 951 1017 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 952 1018 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 953 1019 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 954 REAL(wp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1020 REAL(dp) , INTENT( out), DIMENSION(:) :: pvar ! read field 1021 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1022 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading 1023 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis 1024 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1025 ! 1026 IF( kiomid > 0 ) THEN 1027 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & 1028 & ktime=ktime, kstart=kstart, kcount=kcount, & 1029 & ldxios=ldxios ) 1030 ENDIF 1031 END SUBROUTINE iom_g1d_dp 1032 1033 SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios) 1034 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1035 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1036 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1037 REAL(sp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1038 REAL(dp) , ALLOCATABLE , DIMENSION(:,:) :: ztmp_pvar ! tmp var to read field 955 1039 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 956 1040 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 957 REAL( wp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold1041 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold 958 1042 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 959 1043 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading … … 962 1046 ! 963 1047 IF( kiomid > 0 ) THEN 1048 IF( iom_file(kiomid)%nfid > 0 ) THEN 1049 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2))) 1050 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = ztmp_pvar , ktime = ktime, & 1051 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1052 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1053 pvar = ztmp_pvar 1054 DEALLOCATE(ztmp_pvar) 1055 ENDIF 1056 ENDIF 1057 END SUBROUTINE iom_g2d_sp 1058 1059 SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios) 1060 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1061 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1062 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1063 REAL(dp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1064 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1065 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1066 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold 1067 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1068 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading 1069 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis 1070 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1071 ! 1072 IF( kiomid > 0 ) THEN 964 1073 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = pvar , ktime = ktime, & 965 1074 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 966 1075 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 967 1076 ENDIF 968 END SUBROUTINE iom_g2d 969 970 SUBROUTINE iom_g3d ( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios )1077 END SUBROUTINE iom_g2d_dp 1078 1079 SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios ) 971 1080 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 972 1081 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 973 1082 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 974 REAL(wp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1083 REAL(sp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1084 REAL(dp) , ALLOCATABLE , DIMENSION(:,:,:) :: ztmp_pvar ! tmp var to read field 975 1085 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 976 1086 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 977 REAL( wp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold1087 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold 978 1088 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 979 1089 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading … … 982 1092 ! 983 1093 IF( kiomid > 0 ) THEN 984 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = pvar , ktime = ktime, & 1094 IF( iom_file(kiomid)%nfid > 0 ) THEN 1095 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3))) 1096 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = ztmp_pvar , ktime = ktime, & 985 1097 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 986 1098 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 987 ENDIF 988 END SUBROUTINE iom_g3d 1099 pvar = ztmp_pvar 1100 DEALLOCATE(ztmp_pvar) 1101 END IF 1102 ENDIF 1103 END SUBROUTINE iom_g3d_sp 1104 1105 SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios ) 1106 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1107 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1108 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1109 REAL(dp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1110 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1111 CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1112 REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold 1113 INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1114 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading 1115 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis 1116 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1117 ! 1118 IF( kiomid > 0 ) THEN 1119 IF( iom_file(kiomid)%nfid > 0 ) THEN 1120 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = pvar , ktime = ktime, & 1121 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1122 & kstart = kstart , kcount = kcount, ldxios=ldxios ) 1123 END IF 1124 ENDIF 1125 END SUBROUTINE iom_g3d_dp 1126 989 1127 !!---------------------------------------------------------------------- 990 1128 … … 1001 1139 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1002 1140 CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable 1003 REAL( wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case)1004 REAL( wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case)1005 REAL( wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case)1141 REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 1142 REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 1143 REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 1006 1144 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 1007 1145 CHARACTER(len=1) , INTENT(in ), OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) 1008 REAL( wp) , INTENT(in ), OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold1146 REAL(dp) , INTENT(in ), OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold 1009 1147 INTEGER , INTENT(in ), OPTIONAL :: kfill ! value of kfillmode in lbc_lbk 1010 1148 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis … … 1029 1167 INTEGER, DIMENSION(jpmax_dims) :: idimsz ! size of the dimensions of the variable 1030 1168 INTEGER, DIMENSION(jpmax_dims) :: ishape ! size of the dimensions of the variable 1031 REAL( wp) :: zscf, zofs ! sacle_factor and add_offset1169 REAL(dp) :: zscf, zofs ! sacle_factor and add_offset 1032 1170 REAL(wp) :: zsgn ! local value of psgn 1033 1171 INTEGER :: itmp ! temporary integer … … 1038 1176 LOGICAL :: ll_only3rd ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 1039 1177 INTEGER :: inlev ! number of levels for 3D data 1040 REAL( wp) :: gma, gmi1178 REAL(dp) :: gma, gmi 1041 1179 !--------------------------------------------------------------------- 1042 1180 ! … … 1238 1376 !some final adjustments 1239 1377 ! C1D case : always call lbc_lnk to replicate the central value over the whole 3X3 domain 1240 IF( lk_c1d .AND. PRESENT(pv_r2d) ) CALL lbc_lnk( 'iom', pv_r2d,'Z',1. )1241 IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1. )1378 IF( lk_c1d .AND. PRESENT(pv_r2d) ) CALL lbc_lnk( 'iom', pv_r2d,'Z',1.0_wp ) 1379 IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1.0_wp ) 1242 1380 1243 1381 !--- Apply scale_factor and offset … … 1426 1564 !! INTERFACE iom_rstput 1427 1565 !!---------------------------------------------------------------------- 1428 SUBROUTINE iom_rp0d ( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1566 SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1429 1567 INTEGER , INTENT(in) :: kt ! ocean time-step 1430 1568 INTEGER , INTENT(in) :: kwrite ! writing time-step 1431 1569 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1432 1570 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1433 REAL( wp) , INTENT(in) :: pvar ! written field1571 REAL(sp) , INTENT(in) :: pvar ! written field 1434 1572 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1435 1573 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1450 1588 IF( iom_file(kiomid)%nfid > 0 ) THEN 1451 1589 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1452 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar)1590 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = real(pvar, dp) ) 1453 1591 ENDIF 1454 1592 ENDIF 1455 1593 ENDIF 1456 END SUBROUTINE iom_rp0d 1457 1458 SUBROUTINE iom_rp 1d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1594 END SUBROUTINE iom_rp0d_sp 1595 1596 SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1459 1597 INTEGER , INTENT(in) :: kt ! ocean time-step 1460 1598 INTEGER , INTENT(in) :: kwrite ! writing time-step 1461 1599 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1462 1600 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1463 REAL(wp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1601 REAL(dp) , INTENT(in) :: pvar ! written field 1602 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1603 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1604 LOGICAL :: llx ! local xios write flag 1605 INTEGER :: ivid ! variable id 1606 1607 llx = .FALSE. 1608 IF(PRESENT(ldxios)) llx = ldxios 1609 IF( llx ) THEN 1610 #ifdef key_iomput 1611 IF( kt == kwrite ) THEN 1612 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1613 CALL xios_send_field(trim(cdvar), pvar) 1614 ENDIF 1615 #endif 1616 ELSE 1617 IF( kiomid > 0 ) THEN 1618 IF( iom_file(kiomid)%nfid > 0 ) THEN 1619 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1620 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) 1621 ENDIF 1622 ENDIF 1623 ENDIF 1624 END SUBROUTINE iom_rp0d_dp 1625 1626 1627 SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1628 INTEGER , INTENT(in) :: kt ! ocean time-step 1629 INTEGER , INTENT(in) :: kwrite ! writing time-step 1630 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1631 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1632 REAL(sp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1464 1633 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1465 1634 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1480 1649 IF( iom_file(kiomid)%nfid > 0 ) THEN 1481 1650 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1482 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar)1651 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = real(pvar, dp) ) 1483 1652 ENDIF 1484 1653 ENDIF 1485 1654 ENDIF 1486 END SUBROUTINE iom_rp1d 1487 1488 SUBROUTINE iom_rp 2d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1655 END SUBROUTINE iom_rp1d_sp 1656 1657 SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1489 1658 INTEGER , INTENT(in) :: kt ! ocean time-step 1490 1659 INTEGER , INTENT(in) :: kwrite ! writing time-step 1491 1660 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1492 1661 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1493 REAL(wp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1662 REAL(dp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1663 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1664 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1665 LOGICAL :: llx ! local xios write flag 1666 INTEGER :: ivid ! variable id 1667 1668 llx = .FALSE. 1669 IF(PRESENT(ldxios)) llx = ldxios 1670 IF( llx ) THEN 1671 #ifdef key_iomput 1672 IF( kt == kwrite ) THEN 1673 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1674 CALL xios_send_field(trim(cdvar), pvar) 1675 ENDIF 1676 #endif 1677 ELSE 1678 IF( kiomid > 0 ) THEN 1679 IF( iom_file(kiomid)%nfid > 0 ) THEN 1680 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1681 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) 1682 ENDIF 1683 ENDIF 1684 ENDIF 1685 END SUBROUTINE iom_rp1d_dp 1686 1687 1688 SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1689 INTEGER , INTENT(in) :: kt ! ocean time-step 1690 INTEGER , INTENT(in) :: kwrite ! writing time-step 1691 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1692 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1693 REAL(sp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1494 1694 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1495 1695 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1510 1710 IF( iom_file(kiomid)%nfid > 0 ) THEN 1511 1711 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1512 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar)1712 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = real(pvar, dp) ) 1513 1713 ENDIF 1514 1714 ENDIF 1515 1715 ENDIF 1516 END SUBROUTINE iom_rp2d 1517 1518 SUBROUTINE iom_rp 3d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1716 END SUBROUTINE iom_rp2d_sp 1717 1718 SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1519 1719 INTEGER , INTENT(in) :: kt ! ocean time-step 1520 1720 INTEGER , INTENT(in) :: kwrite ! writing time-step 1521 1721 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1522 1722 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1523 REAL(wp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1723 REAL(dp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1724 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1725 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1726 LOGICAL :: llx 1727 INTEGER :: ivid ! variable id 1728 1729 llx = .FALSE. 1730 IF(PRESENT(ldxios)) llx = ldxios 1731 IF( llx ) THEN 1732 #ifdef key_iomput 1733 IF( kt == kwrite ) THEN 1734 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1735 CALL xios_send_field(trim(cdvar), pvar) 1736 ENDIF 1737 #endif 1738 ELSE 1739 IF( kiomid > 0 ) THEN 1740 IF( iom_file(kiomid)%nfid > 0 ) THEN 1741 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1742 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) 1743 ENDIF 1744 ENDIF 1745 ENDIF 1746 END SUBROUTINE iom_rp2d_dp 1747 1748 1749 SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1750 INTEGER , INTENT(in) :: kt ! ocean time-step 1751 INTEGER , INTENT(in) :: kwrite ! writing time-step 1752 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1753 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1754 REAL(sp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1524 1755 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1525 1756 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1540 1771 IF( iom_file(kiomid)%nfid > 0 ) THEN 1541 1772 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1773 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = real(pvar, dp) ) 1774 ENDIF 1775 ENDIF 1776 ENDIF 1777 END SUBROUTINE iom_rp3d_sp 1778 1779 SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1780 INTEGER , INTENT(in) :: kt ! ocean time-step 1781 INTEGER , INTENT(in) :: kwrite ! writing time-step 1782 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1783 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1784 REAL(dp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1785 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1786 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1787 LOGICAL :: llx ! local xios write flag 1788 INTEGER :: ivid ! variable id 1789 1790 llx = .FALSE. 1791 IF(PRESENT(ldxios)) llx = ldxios 1792 IF( llx ) THEN 1793 #ifdef key_iomput 1794 IF( kt == kwrite ) THEN 1795 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1796 CALL xios_send_field(trim(cdvar), pvar) 1797 ENDIF 1798 #endif 1799 ELSE 1800 IF( kiomid > 0 ) THEN 1801 IF( iom_file(kiomid)%nfid > 0 ) THEN 1802 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1542 1803 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) 1543 1804 ENDIF 1544 1805 ENDIF 1545 1806 ENDIF 1546 END SUBROUTINE iom_rp3d 1807 END SUBROUTINE iom_rp3d_dp 1808 1547 1809 1548 1810 … … 1596 1858 !! INTERFACE iom_put 1597 1859 !!---------------------------------------------------------------------- 1598 SUBROUTINE iom_p0d ( cdname, pfield0d )1860 SUBROUTINE iom_p0d_sp( cdname, pfield0d ) 1599 1861 CHARACTER(LEN=*), INTENT(in) :: cdname 1600 REAL( wp) , INTENT(in) :: pfield0d1862 REAL(sp) , INTENT(in) :: pfield0d 1601 1863 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1602 1864 #if defined key_iomput … … 1607 1869 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings 1608 1870 #endif 1609 END SUBROUTINE iom_p0d 1610 1611 SUBROUTINE iom_p1d( cdname, pfield1d ) 1871 END SUBROUTINE iom_p0d_sp 1872 1873 SUBROUTINE iom_p0d_dp( cdname, pfield0d ) 1874 CHARACTER(LEN=*), INTENT(in) :: cdname 1875 REAL(dp) , INTENT(in) :: pfield0d 1876 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1877 #if defined key_iomput 1878 !!clem zz(:,:)=pfield0d 1879 !!clem CALL xios_send_field(cdname, zz) 1880 CALL xios_send_field(cdname, (/pfield0d/)) 1881 #else 1882 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings 1883 #endif 1884 END SUBROUTINE iom_p0d_dp 1885 1886 1887 SUBROUTINE iom_p1d_sp( cdname, pfield1d ) 1612 1888 CHARACTER(LEN=*) , INTENT(in) :: cdname 1613 REAL( wp), DIMENSION(:), INTENT(in) :: pfield1d1889 REAL(sp), DIMENSION(:), INTENT(in) :: pfield1d 1614 1890 #if defined key_iomput 1615 1891 CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) … … 1617 1893 IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings 1618 1894 #endif 1619 END SUBROUTINE iom_p1d 1620 1621 SUBROUTINE iom_p2d( cdname, pfield2d ) 1895 END SUBROUTINE iom_p1d_sp 1896 1897 SUBROUTINE iom_p1d_dp( cdname, pfield1d ) 1898 CHARACTER(LEN=*) , INTENT(in) :: cdname 1899 REAL(dp), DIMENSION(:), INTENT(in) :: pfield1d 1900 #if defined key_iomput 1901 CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) 1902 #else 1903 IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings 1904 #endif 1905 END SUBROUTINE iom_p1d_dp 1906 1907 SUBROUTINE iom_p2d_sp( cdname, pfield2d ) 1622 1908 CHARACTER(LEN=*) , INTENT(in) :: cdname 1623 REAL( wp), DIMENSION(:,:), INTENT(in) :: pfield2d1909 REAL(sp), DIMENSION(:,:), INTENT(in) :: pfield2d 1624 1910 IF( iom_use(cdname) ) THEN 1625 1911 #if defined key_iomput … … 1633 1919 #endif 1634 1920 ENDIF 1635 END SUBROUTINE iom_p2d 1636 1637 SUBROUTINE iom_p3d( cdname, pfield3d ) 1921 END SUBROUTINE iom_p2d_sp 1922 1923 SUBROUTINE iom_p2d_dp( cdname, pfield2d ) 1924 CHARACTER(LEN=*) , INTENT(in) :: cdname 1925 REAL(dp), DIMENSION(:,:), INTENT(in) :: pfield2d 1926 IF( iom_use(cdname) ) THEN 1927 #if defined key_iomput 1928 IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 1929 CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) ) ! this extraction will create a copy of pfield2d 1930 ELSE 1931 CALL xios_send_field( cdname, pfield2d ) 1932 ENDIF 1933 #else 1934 WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1935 #endif 1936 ENDIF 1937 END SUBROUTINE iom_p2d_dp 1938 1939 SUBROUTINE iom_p3d_sp( cdname, pfield3d ) 1638 1940 CHARACTER(LEN=*) , INTENT(in) :: cdname 1639 REAL( wp), DIMENSION(:,:,:), INTENT(in) :: pfield3d1941 REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 1640 1942 IF( iom_use(cdname) ) THEN 1641 1943 #if defined key_iomput … … 1649 1951 #endif 1650 1952 ENDIF 1651 END SUBROUTINE iom_p3d 1652 1653 SUBROUTINE iom_p 4d( cdname, pfield4d )1953 END SUBROUTINE iom_p3d_sp 1954 1955 SUBROUTINE iom_p3d_dp( cdname, pfield3d ) 1654 1956 CHARACTER(LEN=*) , INTENT(in) :: cdname 1655 REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 1957 REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 1958 IF( iom_use(cdname) ) THEN 1959 #if defined key_iomput 1960 IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 1961 CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) ) ! this extraction will create a copy of pfield3d 1962 ELSE 1963 CALL xios_send_field( cdname, pfield3d ) 1964 ENDIF 1965 #else 1966 WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1967 #endif 1968 ENDIF 1969 END SUBROUTINE iom_p3d_dp 1970 1971 SUBROUTINE iom_p4d_sp( cdname, pfield4d ) 1972 CHARACTER(LEN=*) , INTENT(in) :: cdname 1973 REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 1656 1974 IF( iom_use(cdname) ) THEN 1657 1975 #if defined key_iomput … … 1665 1983 #endif 1666 1984 ENDIF 1667 END SUBROUTINE iom_p4d 1668 1985 END SUBROUTINE iom_p4d_sp 1986 1987 SUBROUTINE iom_p4d_dp( cdname, pfield4d ) 1988 CHARACTER(LEN=*) , INTENT(in) :: cdname 1989 REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 1990 IF( iom_use(cdname) ) THEN 1991 #if defined key_iomput 1992 IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 1993 CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) ) ! this extraction will create a copy of pfield4d 1994 ELSE 1995 CALL xios_send_field (cdname, pfield4d ) 1996 ENDIF 1997 #else 1998 WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 1999 #endif 2000 ENDIF 2001 END SUBROUTINE iom_p4d_dp 1669 2002 1670 2003 #if defined key_iomput … … 1682 2015 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1683 2016 INTEGER , OPTIONAL, INTENT(in) :: nvertex 1684 REAL( wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue1685 REAL( wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area2017 REAL(dp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 2018 REAL(dp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1686 2019 LOGICAL , DIMENSION(:) , OPTIONAL, INTENT(in) :: mask 1687 2020 !!---------------------------------------------------------------------- … … 1746 2079 !!---------------------------------------------------------------------- 1747 2080 IF( PRESENT(paxis) ) THEN 1748 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=paxis ) 1749 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 1750 ENDIF 1751 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=bounds ) 1752 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 2081 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 2082 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 2083 ENDIF 2084 IF( PRESENT(bounds) ) THEN 2085 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=real(bounds, dp) ) 2086 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=real(bounds, dp) ) 2087 ELSE 2088 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid) 2089 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid) 2090 END IF 1753 2091 CALL xios_solve_inheritance() 1754 2092 END SUBROUTINE iom_set_axis_attr … … 1865 2203 !don't define lon and lat for restart reading context. 1866 2204 IF ( .NOT.ldrxios ) & 1867 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)), &1868 & latvalue = RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)))2205 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = real(RESHAPE(plon(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp), & 2206 & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp )) 1869 2207 ! 1870 2208 IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN … … 1883 2221 END SUBROUTINE set_grid 1884 2222 1885 1886 2223 SUBROUTINE set_grid_bounds( cdgrd, plon_cnr, plat_cnr, plon_pnt, plat_pnt ) 1887 2224 !!---------------------------------------------------------------------- … … 1897 2234 INTEGER :: ji, jj, jn 1898 2235 INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) 1899 ! ! represents the bottom-left corner of cell (i,j) 2236 ! ! represents the 2237 ! bottom-left corner of 2238 ! cell (i,j) 1900 2239 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j) 1901 2240 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells … … 1913 2252 ! 1914 2253 z_fld(:,:) = 1._wp 1915 CALL lbc_lnk( 'iom', z_fld, cdgrd, -1. ) ! Working array for location of northfold2254 CALL lbc_lnk( 'iom', z_fld, cdgrd, -1.0_wp ) ! Working array for location of northfold 1916 2255 ! 1917 2256 ! Cell vertices that can be defined … … 1935 2274 END_2D 1936 2275 ! 1937 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,1),(/ 4,Ni_0*Nj_0 /)), &1938 & bounds_lon = RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,2),(/ 4,Ni_0*Nj_0 /)), nvertex=4 )1939 ! 1940 DEALLOCATE( z_bnds, z_fld, z_rot ) 2276 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,1),(/ 4,Ni_0*Nj_0 /)), dp), & 2277 & bounds_lon = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,2),(/ 4,Ni_0*Nj_0 /)), dp), nvertex=4 ) 2278 ! 2279 DEALLOCATE( z_bnds, z_fld, z_rot ) 1941 2280 ! 1942 2281 END SUBROUTINE set_grid_bounds 1943 1944 2282 1945 2283 SUBROUTINE set_grid_znl( plat ) … … 1958 2296 ALLOCATE( zlon(Ni_0*Nj_0) ) ; zlon(:) = 0._wp 1959 2297 ! 1960 ! CALL dom_ngb( -168.53 , 65.03, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots)1961 CALL dom_ngb( 180. , 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots)2298 ! CALL dom_ngb( -168.53_wp, 65.03_wp, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) 2299 CALL dom_ngb( 180.0_wp, 90.0_wp, ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 1962 2300 CALL iom_set_domain_attr("gznl", ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig0(Nis0)-1, jbegin=mjg0(Njs0)-1, ni=Ni_0, nj=Nj_0) 1963 2301 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0) 1964 CALL iom_set_domain_attr("gznl", lonvalue = zlon, &1965 & latvalue = RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)))2302 CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp), & 2303 & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp)) 1966 2304 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj_0) 1967 2305 ! … … 1978 2316 !! 1979 2317 !!---------------------------------------------------------------------- 1980 REAL( wp), DIMENSION(1) :: zz = 1.2318 REAL(dp), DIMENSION(1) :: zz = 1. 1981 2319 !!---------------------------------------------------------------------- 1982 2320 ! … … 2040 2378 cl1 = clgrd(jg) 2041 2379 ! Equatorial section (attributs: jbegin, ni, name_suffix) 2042 CALL dom_ngb( 0. , 0., ix, iy, cl1 )2380 CALL dom_ngb( 0.0_wp, 0.0_wp, ix, iy, cl1 ) 2043 2381 CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni=Ni0glo, nj=1 ) 2044 2382 CALL iom_get_file_attr ('Eq'//cl1, name_suffix = clsuff ) … … 2266 2604 ! 2267 2605 IF ( ll24 .AND. isec == 0 ) THEN ! 00:00 of the next day -> move to 24:00 of the current day 2268 CALL ju2ymds( pjday - 1. , iyear, imonth, iday, zsec )2606 CALL ju2ymds( pjday - 1.0_wp, iyear, imonth, iday, zsec ) 2269 2607 isec = 86400 2270 2608 ENDIF … … 2324 2662 CHARACTER(LEN=*), INTENT(in ) :: cdname 2325 2663 REAL(wp) , INTENT(out) :: pmiss_val 2664 REAL(dp) :: ztmp_pmiss_val 2326 2665 #if defined key_iomput 2327 2666 ! get missing value 2328 CALL xios_get_field_attr( cdname, default_value = pmiss_val ) 2667 CALL xios_get_field_attr( cdname, default_value = ztmp_pmiss_val ) 2668 pmiss_val = ztmp_pmiss_val 2329 2669 #else 2330 2670 IF( .FALSE. ) WRITE(numout,*) cdname, pmiss_val ! useless test to avoid compilation warnings -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/IOM/iom_nf90.F90
r13130 r13247 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 … … 275 276 !!---------------------------------------------------------------------- 276 277 277 SUBROUTINE iom_nf90_g0d ( kiomid, kvid, pvar, kstart )278 SUBROUTINE iom_nf90_g0d_sp( kiomid, kvid, pvar, kstart ) 278 279 !!----------------------------------------------------------------------- 279 280 !! *** ROUTINE iom_nf90_g0d *** … … 283 284 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 284 285 INTEGER , INTENT(in ) :: kvid ! variable id 285 REAL( wp), INTENT( out) :: pvar ! read field286 REAL(sp), INTENT( out) :: pvar ! read field 286 287 INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 287 288 ! … … 290 291 clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) 291 292 CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) 292 END SUBROUTINE iom_nf90_g0d 293 294 295 SUBROUTINE iom_nf90_g123d( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, & 293 END SUBROUTINE iom_nf90_g0d_sp 294 295 SUBROUTINE iom_nf90_g0d_dp( kiomid, kvid, pvar, kstart ) 296 !!----------------------------------------------------------------------- 297 !! *** ROUTINE iom_nf90_g0d *** 298 !! 299 !! ** Purpose : read a scalar with NF90 300 !!----------------------------------------------------------------------- 301 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 302 INTEGER , INTENT(in ) :: kvid ! variable id 303 REAL(dp), INTENT( out) :: pvar ! read field 304 INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 305 ! 306 CHARACTER(LEN=100) :: clinfo ! info character 307 !--------------------------------------------------------------------- 308 clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) 309 CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) 310 END SUBROUTINE iom_nf90_g0d_dp 311 312 SUBROUTINE iom_nf90_g123d_dp( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, & 296 313 & pv_r1d, pv_r2d, pv_r3d ) 297 314 !!----------------------------------------------------------------------- … … 308 325 INTEGER , DIMENSION(:) , INTENT(in ) :: kcount ! number of points to be read in each axis 309 326 INTEGER , INTENT(in ) :: kx1, kx2, ky1, ky2 ! subdomain indexes 310 REAL( wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case)311 REAL( wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case)312 REAL( wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case)327 REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 328 REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 329 REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 313 330 ! 314 331 CHARACTER(LEN=100) :: clinfo ! info character … … 331 348 ENDIF 332 349 ! 333 END SUBROUTINE iom_nf90_g123d 350 END SUBROUTINE iom_nf90_g123d_dp 351 334 352 335 353 … … 505 523 END SUBROUTINE iom_nf90_putatt 506 524 507 508 SUBROUTINE iom_nf90_rp0123d( kt, kwrite, kiomid, cdvar , kvid , ktype, & 525 SUBROUTINE iom_nf90_rp0123d_dp( kt, kwrite, kiomid, cdvar , kvid , ktype, & 509 526 & pv_r0d, pv_r1d, pv_r2d, pv_r3d ) 510 527 !!-------------------------------------------------------------------- … … 519 536 INTEGER , INTENT(in) :: kvid ! variable id 520 537 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable type (default R8) 521 REAL( wp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field522 REAL( wp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field523 REAL( wp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field524 REAL( wp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field538 REAL(dp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field 539 REAL(dp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field 540 REAL(dp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field 541 REAL(dp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field 525 542 ! 526 543 INTEGER :: idims ! number of dimension … … 703 720 ENDIF 704 721 ! 705 END SUBROUTINE iom_nf90_rp0123d 722 END SUBROUTINE iom_nf90_rp0123d_dp 706 723 707 724 -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/ISF/isfcav.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/ISF/isfcpl.F90
r12807 r13247 195 195 zssmask0(:,:) = zssmask_b(:,:) 196 196 ! 197 CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1. , zssmask0, 'T', 1.)197 CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1.0_wp, zssmask0, 'T', 1.0_wp ) 198 198 ! 199 199 END DO … … 348 348 ztmask0(:,:,:) = ztmask1(:,:,:) 349 349 ! 350 CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1. , zts0(:,:,:,jp_sal), 'T', 1., ztmask0, 'T', 1.)350 CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1.0_wp, zts0(:,:,:,jp_sal), 'T', 1.0_wp, ztmask0, 'T', 1.0_wp) 351 351 ! 352 352 END DO ! nn_drown … … 433 433 END_2D 434 434 ! 435 CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1. )435 CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1.0_wp ) 436 436 ! 437 437 ! 3.0: set total correction (div, tr(:,:,:,:,Krhs), ssh) … … 602 602 ELSE IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN 603 603 ! spread correction amoung neigbourg wet cells (vertical direction) 604 CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1. , 0)604 CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1.0_wp, 0) 605 605 ELSE 606 606 ! need to find where to put correction in later on 607 CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1. , 1)607 CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1.0_wp, 1) 608 608 END IF 609 609 END IF … … 665 665 ! 666 666 ! add lbclnk 667 CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1. , risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1., &668 & risfcpl_cons_vol(:,:,:) , 'T', 1. )667 CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_wp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_wp, & 668 & risfcpl_cons_vol(:,:,:) , 'T', 1.0_wp) 669 669 ! 670 670 ! ssh correction (for dynspg_ts) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/ISF/isfpar.F90
r12489 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/lbc_lnk_multi_generic.h90
r12586 r13247 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 … … 78 98 END SUBROUTINE ROUTINE_LOAD 79 99 100 #undef PRECISION 80 101 #undef ARRAY_TYPE 81 102 #undef PTR_TYPE -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/lbc_nfd_ext_generic.h90
r12807 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/lbc_nfd_generic.h90
r13174 r13247 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 J_SIZE(ptab) SIZE(ptab(1)%pt2d,2) … … 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 J_SIZE(ptab) SIZE(ptab(1)%pt3d,2) … … 18 26 # endif 19 27 # if defined DIM_4d 20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f) 28 # if defined SINGLE_PRECISION 29 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 30 # else 31 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 32 # endif 21 33 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 22 34 # define J_SIZE(ptab) SIZE(ptab(1)%pt4d,2) … … 47 59 # define L_SIZE(ptab) SIZE(ptab,4) 48 60 # endif 49 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 61 # if defined SINGLE_PRECISION 62 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 63 # else 64 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 65 # endif 50 66 #endif 67 68 # if defined SINGLE_PRECISION 69 # define PRECISION sp 70 # else 71 # define PRECISION dp 72 # endif 51 73 52 74 #if defined MULTI … … 437 459 END SUBROUTINE ROUTINE_NFD 438 460 461 #undef PRECISION 439 462 #undef ARRAY_TYPE 440 463 #undef ARRAY_IN -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r12993 r13247 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 J_SIZE(ptab2) SIZE(ptab2,2) 47 63 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l) 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 !!---------------------------------------------------------------------- … … 412 437 END DO ! End jf loop 413 438 END SUBROUTINE ROUTINE_NFD 439 #undef PRECISION 414 440 #undef ARRAY_TYPE 415 441 #undef ARRAY_IN -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/lbclnk.F90
r12807 r13247 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, iis0, iie0, 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 iis0 = nis0all(iproc) 285 iie0 = nie0all(iproc) 286 iilb = nimppt(iproc) 287 DO jj = 1-kextj, ipj+kextj 288 DO ji = iis0, iie0 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 - (2 * nn_hls) - 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 - ( 2 * nn_hls ) -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_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/lbcnfd.F90
r12586 r13247 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 … … 76 93 !!---------------------------------------------------------------------- 77 94 ! 78 ! !== 2D array and array of 2D pointer ==! 79 ! 80 # define DIM_2d 81 # define ROUTINE_NFD lbc_nfd_2d 82 # include "lbc_nfd_generic.h90" 83 # undef ROUTINE_NFD 84 # define MULTI 85 # define ROUTINE_NFD lbc_nfd_2d_ptr 95 ! !== SINGLE PRECISION VERSIONS 96 ! 97 ! 98 ! !== 2D array and array of 2D pointer ==! 99 ! 100 # define SINGLE_PRECISION 101 # define DIM_2d 102 # define ROUTINE_NFD lbc_nfd_2d_sp 103 # include "lbc_nfd_generic.h90" 104 # undef ROUTINE_NFD 105 # define MULTI 106 # define ROUTINE_NFD lbc_nfd_2d_ptr_sp 86 107 # include "lbc_nfd_generic.h90" 87 108 # undef ROUTINE_NFD … … 92 113 ! 93 114 # define DIM_2d 94 # define ROUTINE_NFD lbc_nfd_2d_ext 115 # define ROUTINE_NFD lbc_nfd_2d_ext_sp 95 116 # include "lbc_nfd_ext_generic.h90" 96 117 # undef ROUTINE_NFD … … 100 121 ! 101 122 # define DIM_3d 102 # define ROUTINE_NFD lbc_nfd_3d 103 # include "lbc_nfd_generic.h90" 104 # undef ROUTINE_NFD 105 # define MULTI 106 # define ROUTINE_NFD lbc_nfd_3d_ptr 107 # include "lbc_nfd_generic.h90" 108 # undef ROUTINE_NFD 109 # undef MULTI 110 # undef DIM_3d 111 ! 112 ! !== 4D array and array of 4D pointer ==! 113 ! 114 # define DIM_4d 115 # define ROUTINE_NFD lbc_nfd_4d 116 # include "lbc_nfd_generic.h90" 117 # undef ROUTINE_NFD 118 # define MULTI 119 # define ROUTINE_NFD lbc_nfd_4d_ptr 123 # define ROUTINE_NFD lbc_nfd_3d_sp 124 # include "lbc_nfd_generic.h90" 125 # undef ROUTINE_NFD 126 # define MULTI 127 # define ROUTINE_NFD lbc_nfd_3d_ptr_sp 128 # include "lbc_nfd_generic.h90" 129 # undef ROUTINE_NFD 130 # undef MULTI 131 # undef DIM_3d 132 ! 133 ! !== 4D array and array of 4D pointer ==! 134 ! 135 # define DIM_4d 136 # define ROUTINE_NFD lbc_nfd_4d_sp 137 # include "lbc_nfd_generic.h90" 138 # undef ROUTINE_NFD 139 # define MULTI 140 # define ROUTINE_NFD lbc_nfd_4d_ptr_sp 120 141 # include "lbc_nfd_generic.h90" 121 142 # undef ROUTINE_NFD … … 128 149 ! 129 150 # define DIM_2d 130 # define ROUTINE_NFD lbc_nfd_nogather_2d 131 # include "lbc_nfd_nogather_generic.h90" 132 # undef ROUTINE_NFD 133 # define MULTI 134 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr 135 # include "lbc_nfd_nogather_generic.h90" 136 # undef ROUTINE_NFD 137 # undef MULTI 138 # undef DIM_2d 139 ! 140 ! !== 3D array and array of 3D pointer ==! 141 ! 142 # define DIM_3d 143 # define ROUTINE_NFD lbc_nfd_nogather_3d 144 # include "lbc_nfd_nogather_generic.h90" 145 # undef ROUTINE_NFD 146 # define MULTI 147 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr 148 # include "lbc_nfd_nogather_generic.h90" 149 # undef ROUTINE_NFD 150 # undef MULTI 151 # undef DIM_3d 152 ! 153 ! !== 4D array and array of 4D pointer ==! 154 ! 155 # define DIM_4d 156 # define ROUTINE_NFD lbc_nfd_nogather_4d 151 # define ROUTINE_NFD lbc_nfd_nogather_2d_sp 152 # include "lbc_nfd_nogather_generic.h90" 153 # undef ROUTINE_NFD 154 # define MULTI 155 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_sp 156 # include "lbc_nfd_nogather_generic.h90" 157 # undef ROUTINE_NFD 158 # undef MULTI 159 # undef DIM_2d 160 ! 161 ! !== 3D array and array of 3D pointer ==! 162 ! 163 # define DIM_3d 164 # define ROUTINE_NFD lbc_nfd_nogather_3d_sp 165 # include "lbc_nfd_nogather_generic.h90" 166 # undef ROUTINE_NFD 167 # define MULTI 168 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_sp 169 # include "lbc_nfd_nogather_generic.h90" 170 # undef ROUTINE_NFD 171 # undef MULTI 172 # undef DIM_3d 173 ! 174 ! !== 4D array and array of 4D pointer ==! 175 ! 176 # define DIM_4d 177 # define ROUTINE_NFD lbc_nfd_nogather_4d_sp 157 178 # include "lbc_nfd_nogather_generic.h90" 158 179 # undef ROUTINE_NFD … … 163 184 !# undef MULTI 164 185 # undef DIM_4d 165 166 !!---------------------------------------------------------------------- 186 # undef SINGLE_PRECISION 187 188 !!---------------------------------------------------------------------- 189 ! 190 ! !== DOUBLE PRECISION VERSIONS 191 ! 192 ! 193 ! !== 2D array and array of 2D pointer ==! 194 ! 195 # define DIM_2d 196 # define ROUTINE_NFD lbc_nfd_2d_dp 197 # include "lbc_nfd_generic.h90" 198 # undef ROUTINE_NFD 199 # define MULTI 200 # define ROUTINE_NFD lbc_nfd_2d_ptr_dp 201 # include "lbc_nfd_generic.h90" 202 # undef ROUTINE_NFD 203 # undef MULTI 204 # undef DIM_2d 205 ! 206 ! !== 2D array with extra haloes ==! 207 ! 208 # define DIM_2d 209 # define ROUTINE_NFD lbc_nfd_2d_ext_dp 210 # include "lbc_nfd_ext_generic.h90" 211 # undef ROUTINE_NFD 212 # undef DIM_2d 213 ! 214 ! !== 3D array and array of 3D pointer ==! 215 ! 216 # define DIM_3d 217 # define ROUTINE_NFD lbc_nfd_3d_dp 218 # include "lbc_nfd_generic.h90" 219 # undef ROUTINE_NFD 220 # define MULTI 221 # define ROUTINE_NFD lbc_nfd_3d_ptr_dp 222 # include "lbc_nfd_generic.h90" 223 # undef ROUTINE_NFD 224 # undef MULTI 225 # undef DIM_3d 226 ! 227 ! !== 4D array and array of 4D pointer ==! 228 ! 229 # define DIM_4d 230 # define ROUTINE_NFD lbc_nfd_4d_dp 231 # include "lbc_nfd_generic.h90" 232 # undef ROUTINE_NFD 233 # define MULTI 234 # define ROUTINE_NFD lbc_nfd_4d_ptr_dp 235 # include "lbc_nfd_generic.h90" 236 # undef ROUTINE_NFD 237 # undef MULTI 238 # undef DIM_4d 239 ! 240 ! lbc_nfd_nogather routines 241 ! 242 ! !== 2D array and array of 2D pointer ==! 243 ! 244 # define DIM_2d 245 # define ROUTINE_NFD lbc_nfd_nogather_2d_dp 246 # include "lbc_nfd_nogather_generic.h90" 247 # undef ROUTINE_NFD 248 # define MULTI 249 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_dp 250 # include "lbc_nfd_nogather_generic.h90" 251 # undef ROUTINE_NFD 252 # undef MULTI 253 # undef DIM_2d 254 ! 255 ! !== 3D array and array of 3D pointer ==! 256 ! 257 # define DIM_3d 258 # define ROUTINE_NFD lbc_nfd_nogather_3d_dp 259 # include "lbc_nfd_nogather_generic.h90" 260 # undef ROUTINE_NFD 261 # define MULTI 262 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_dp 263 # include "lbc_nfd_nogather_generic.h90" 264 # undef ROUTINE_NFD 265 # undef MULTI 266 # undef DIM_3d 267 ! 268 ! !== 4D array and array of 4D pointer ==! 269 ! 270 # define DIM_4d 271 # define ROUTINE_NFD lbc_nfd_nogather_4d_dp 272 # include "lbc_nfd_nogather_generic.h90" 273 # undef ROUTINE_NFD 274 !# define MULTI 275 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr 276 !# include "lbc_nfd_nogather_generic.h90" 277 !# undef ROUTINE_NFD 278 !# undef MULTI 279 # undef DIM_4d 280 281 !!---------------------------------------------------------------------- 282 167 283 168 284 -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/lib_mpp.F90
r13229 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_allreduce_generic.h90
r10425 r13247 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_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
r13227 r13247 36 36 ! 37 37 INTEGER :: ji, jj, jr 38 INTEGER :: ierr, itaille, i ldi, ilei, iilb38 INTEGER :: ierr, itaille, iis0, iie0, iilb 39 39 INTEGER :: ipj, ij, iproc 40 40 ! … … 75 75 DO jr = 1, ndim_rank_north ! recover the global north array 76 76 iproc = nrank_north(jr) + 1 77 ildi = nldit (iproc) 78 ilei = nleit(iproc)77 iis0 = nis0all(iproc) 78 iie0 = nie0all(iproc) 79 79 iilb = nimppt(iproc) 80 80 DO jj = 1-kextj, ipj+kextj 81 DO ji = i ldi, ilei81 DO ji = iis0, iie0 82 82 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 83 83 END DO -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_lnk_generic.h90
r12993 r13247 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 REAL(wp) :: zland 68 94 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 69 REAL( wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos70 REAL( wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos95 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos 96 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos 71 97 LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send 72 98 LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive … … 168 194 ! 169 195 ! non-blocking send of the western/eastern side using local temporary arrays 170 IF( llsend_we ) CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we )171 IF( llsend_ea ) CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea )196 IF( llsend_we ) CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 197 IF( llsend_ea ) CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 172 198 ! blocking receive of the western/eastern halo in local temporary arrays 173 IF( llrecv_we ) CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe )174 IF( llrecv_ea ) CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea )199 IF( llrecv_we ) CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 200 IF( llrecv_ea ) CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 175 201 ! 176 202 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 275 301 ! 276 302 ! non-blocking send of the southern/northern side 277 IF( llsend_so ) CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so )278 IF( llsend_no ) CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no )303 IF( llsend_so ) CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 304 IF( llsend_no ) CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 279 305 ! blocking receive of the southern/northern halo 280 IF( llrecv_so ) CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso )281 IF( llrecv_no ) CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono )306 IF( llrecv_so ) CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso ) 307 IF( llrecv_no ) CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono ) 282 308 ! 283 309 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 362 388 ! 363 389 END SUBROUTINE ROUTINE_LNK 364 390 #undef PRECISION 391 #undef SENDROUTINE 392 #undef RECVROUTINE 365 393 #undef ARRAY_TYPE 366 394 #undef NAT_IN -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_lnk_icb_generic.h90
r13227 r13247 105 105 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 106 106 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 107 iihom = jpi -nreci-kexti107 iihom = jpi - (2 * nn_hls) -kexti 108 108 DO jl = 1, ipreci 109 109 r2dew(:,jl,1) = pt2d(nn_hls+jl,:) … … 165 165 ! 166 166 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 167 ijhom = jpj -nrecj-kextj167 ijhom = jpj - (2 * nn_hls) - kextj 168 168 DO jl = 1, iprecj 169 169 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_loc_generic.h90
r12939 r13247 1 1 !== IN: ptab is an array ==! 2 # define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k) 3 # define MASK_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: MASK_IN(i,j,k) 2 # if defined SINGLE_PRECISION 3 # define ARRAY_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: ARRAY_IN(i,j,k) 4 # define MASK_TYPE(i,j,k) REAL(sp) , INTENT(in ) :: MASK_IN(i,j,k) 5 # define PRECISION sp 6 # else 7 # define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) 8 # define MASK_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: MASK_IN(i,j,k) 9 # define PRECISION dp 10 # endif 11 4 12 # if defined DIM_2d 5 13 # define ARRAY_IN(i,j,k) ptab(i,j) … … 30 38 ARRAY_TYPE(:,:,:) ! array on which loctrans operation is applied 31 39 MASK_TYPE(:,:,:) ! local mask 32 REAL( wp) , INTENT( out) :: pmin ! Global minimum of ptab40 REAL(PRECISION) , INTENT( out) :: pmin ! Global minimum of ptab 33 41 INDEX_TYPE(:) ! index of minimum in global frame 34 42 ! 35 43 INTEGER :: ierror, ii, idim 36 44 INTEGER :: index0 37 REAL( wp) :: zmin ! local minimum45 REAL(PRECISION) :: zmin ! local minimum 38 46 INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs 39 REAL( wp), DIMENSION(2,1) :: zain, zaout47 REAL(dp), DIMENSION(2,1) :: zain, zaout 40 48 !!----------------------------------------------------------------------- 41 49 ! … … 98 106 END SUBROUTINE ROUTINE_LOC 99 107 108 109 #undef PRECISION 100 110 #undef ARRAY_TYPE 101 #undef MA X_TYPE111 #undef MASK_TYPE 102 112 #undef ARRAY_IN 103 113 #undef MASK_IN -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_nfd_generic.h90
r12993 r13247 5 5 # define LBC_ARG (jf) 6 6 # if defined DIM_2d 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f) 7 # if defined SINGLE_PRECISION 8 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) 9 # else 10 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) 11 # endif 8 12 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 9 13 # define K_SIZE(ptab) 1 … … 11 15 # endif 12 16 # if defined DIM_3d 13 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f) 17 # if defined SINGLE_PRECISION 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) 19 # else 20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) 21 # endif 14 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 15 23 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) … … 17 25 # endif 18 26 # if defined DIM_4d 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f) 27 # if defined SINGLE_PRECISION 28 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) 29 # else 30 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) 31 # endif 20 32 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 21 33 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) … … 24 36 #else 25 37 ! !== IN: ptab is an array ==! 26 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 38 # if defined SINGLE_PRECISION 39 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 40 # else 41 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 42 # endif 27 43 # define NAT_IN(k) cd_nat 28 44 # define SGN_IN(k) psgn … … 45 61 # endif 46 62 #endif 63 64 # if defined SINGLE_PRECISION 65 # define PRECISION sp 66 # define SENDROUTINE mppsend_sp 67 # define RECVROUTINE mpprecv_sp 68 # define MPI_TYPE MPI_REAL 69 # else 70 # define PRECISION dp 71 # define SENDROUTINE mppsend_dp 72 # define RECVROUTINE mpprecv_dp 73 # define MPI_TYPE MPI_DOUBLE_PRECISION 74 # endif 47 75 48 76 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) … … 72 100 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_b ! position of buffer lines 73 101 INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines 74 REAL( wp), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays75 REAL( wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, znorthloc76 REAL( wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio102 REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays 103 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, znorthloc 104 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio 77 105 !!---------------------------------------------------------------------- 78 106 ! … … 165 193 iproc = nfproc(isendto(jr)) 166 194 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 167 CALL mppsend( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) )195 CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 168 196 ENDIF 169 197 END DO … … 224 252 ELSE ! get data from a neighbour trough communication 225 253 ! 226 CALL mpprecv(5, ztabw, ibuffsize, iproc)254 CALL RECVROUTINE(5, ztabw, ibuffsize, iproc) 227 255 DO jl = 1, ipl ; DO jk = 1, ipk 228 256 DO jj = 1, ipj_b … … 286 314 ! start waiting time measurement 287 315 IF( ln_timing ) CALL tic_tac(.TRUE.) 288 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_ DOUBLE_PRECISION, &289 & znorthgloio, ibuffsize, MPI_ DOUBLE_PRECISION, ncomm_north, ierr )316 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_TYPE, & 317 & znorthgloio, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 290 318 ! 291 319 ! stop waiting time measurement … … 335 363 END SUBROUTINE ROUTINE_NFD 336 364 365 #undef PRECISION 366 #undef MPI_TYPE 367 #undef SENDROUTINE 368 #undef RECVROUTINE 337 369 #undef ARRAY_TYPE 338 370 #undef NAT_IN -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LDF/ldfc1d_c2d.F90
r12377 r13247 85 85 pah2(ji,jj,jk) = pahs2(ji,jj) * ( zratio + zc * ( 1._wp + TANH( - ( zdep2 - zh ) * zw) ) ) 86 86 END_3D 87 CALL lbc_lnk( 'ldfc1d_c2d', pah2, 'F', 1. ) ! Lateral boundary conditions87 CALL lbc_lnk( 'ldfc1d_c2d', pah2, 'F', 1.0_wp ) ! Lateral boundary conditions 88 88 ! 89 89 CASE( 'TRA' ) ! U- and V-points (zdep1 & 2 are an approximation in zps-coord.) … … 95 95 END_3D 96 96 ! Lateral boundary conditions 97 CALL lbc_lnk_multi( 'ldfc1d_c2d', pah1, 'U', 1. , pah2, 'V', 1.)97 CALL lbc_lnk_multi( 'ldfc1d_c2d', pah1, 'U', 1.0_wp , pah2, 'V', 1.0_wp ) 98 98 ! 99 99 CASE DEFAULT ! error -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LDF/ldfdyn.F90
r12738 r13247 398 398 ENDIF 399 399 ! 400 CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1. , ahmf, 'F', 1.)400 CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1.0_wp, ahmf, 'F', 1.0_wp ) 401 401 ! 402 402 ! … … 430 430 END DO 431 431 ! 432 CALL lbc_lnk_multi( 'ldfdyn', dtensq, 'T', 1. ) ! lbc_lnk on dshesq not needed432 CALL lbc_lnk_multi( 'ldfdyn', dtensq, 'T', 1.0_wp ) ! lbc_lnk on dshesq not needed 433 433 ! 434 434 DO jk = 1, jpkm1 … … 481 481 ENDIF 482 482 ! 483 CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1. , ahmf, 'F', 1.)483 CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1.0_wp , ahmf, 'F', 1.0_wp ) 484 484 ! 485 485 END SELECT -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LDF/ldfslp.F90
r12377 r13247 224 224 !!gm end modif 225 225 END_3D 226 CALL lbc_lnk_multi( 'ldfslp', zwz, 'U', -1. , zww, 'V', -1.) ! lateral boundary conditions226 CALL lbc_lnk_multi( 'ldfslp', zwz, 'U', -1.0_wp, zww, 'V', -1.0_wp ) ! lateral boundary conditions 227 227 ! 228 228 ! !* horizontal Shapiro filter … … 298 298 !!gm end modif 299 299 END_3D 300 CALL lbc_lnk_multi( 'ldfslp', zwz, 'T', -1. , zww, 'T', -1.) ! lateral boundary conditions300 CALL lbc_lnk_multi( 'ldfslp', zwz, 'T', -1.0_wp, zww, 'T', -1.0_wp ) ! lateral boundary conditions 301 301 ! 302 302 ! !* horizontal Shapiro filter … … 343 343 ! IV. Lateral boundary conditions 344 344 ! =============================== 345 CALL lbc_lnk_multi( 'ldfslp', uslp , 'U', -1. , vslp , 'V', -1. , wslpi, 'W', -1., wslpj, 'W', -1.)345 CALL lbc_lnk_multi( 'ldfslp', uslp , 'U', -1.0_wp , vslp , 'V', -1.0_wp , wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) 346 346 347 347 IF(sn_cfctl%l_prtctl) THEN … … 575 575 wslp2(:,:,1) = 0._wp ! force the surface wslp to zero 576 576 577 CALL lbc_lnk( 'ldfslp', wslp2, 'W', 1. ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked577 CALL lbc_lnk( 'ldfslp', wslp2, 'W', 1.0_wp ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked 578 578 ! 579 579 IF( ln_timing ) CALL timing_stop('ldf_slp_triad') … … 684 684 END_2D 685 685 !!gm this lbc_lnk should be useless.... 686 CALL lbc_lnk_multi( 'ldfslp', uslpml , 'U', -1. , vslpml , 'V', -1. , wslpiml, 'W', -1. , wslpjml, 'W', -1.)686 CALL lbc_lnk_multi( 'ldfslp', uslpml , 'U', -1.0_wp , vslpml , 'V', -1.0_wp , wslpiml, 'W', -1.0_wp , wslpjml, 'W', -1.0_wp ) 687 687 ! 688 688 END SUBROUTINE ldf_slp_mxl -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LDF/ldftra.F90
r12738 r13247 691 691 zaeiw(ji,jj) = MIN( zzaei , paei0 ) ! Max value = paei0 692 692 END_2D 693 CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1. ) ! lateral boundary condition693 CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1.0_wp ) ! lateral boundary condition 694 694 ! 695 695 DO_2D_00_00 … … 697 697 paeiv(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji ,jj+1) ) * vmask(ji,jj,1) 698 698 END_2D 699 CALL lbc_lnk_multi( 'ldftra', paeiu(:,:,1), 'U', 1. , paeiv(:,:,1), 'V', 1.) ! lateral boundary condition699 CALL lbc_lnk_multi( 'ldftra', paeiu(:,:,1), 'U', 1.0_wp , paeiv(:,:,1), 'V', 1.0_wp ) ! lateral boundary condition 700 700 701 701 DO jk = 2, jpkm1 !== deeper values equal the surface one ==! … … 793 793 !!gm to be redesigned.... 794 794 ! !== eiv stream function: output ==! 795 CALL lbc_lnk_multi( 'ldftra', psi_uw, 'U', -1. , psi_vw, 'V', -1.)795 CALL lbc_lnk_multi( 'ldftra', psi_uw, 'U', -1.0_wp , psi_vw, 'V', -1.0_wp ) 796 796 ! 797 797 !!gm CALL iom_put( "psi_eiv_uw", psi_uw ) ! output … … 816 816 & + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj ,jk) ) / e1e2t(ji,jj) 817 817 END_3D 818 CALL lbc_lnk( 'ldftra', zw3d, 'T', 1. ) ! lateral boundary condition818 CALL lbc_lnk( 'ldftra', zw3d, 'T', 1.0_wp ) ! lateral boundary condition 819 819 CALL iom_put( "woce_eiv", zw3d ) 820 820 ! … … 844 844 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 845 845 END_3D 846 CALL lbc_lnk( 'ldftra', zw2d, 'U', -1. )847 CALL lbc_lnk( 'ldftra', zw3d, 'U', -1. )846 CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp ) 847 CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp ) 848 848 CALL iom_put( "ueiv_heattr" , zztmp * zw2d ) ! heat transport in i-direction 849 849 CALL iom_put( "ueiv_heattr3d", zztmp * zw3d ) ! heat transport in i-direction … … 865 865 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 866 866 END_3D 867 CALL lbc_lnk( 'ldftra', zw2d, 'V', -1. )867 CALL lbc_lnk( 'ldftra', zw2d, 'V', -1.0_wp ) 868 868 CALL iom_put( "veiv_heattr", zztmp * zw2d ) ! heat transport in j-direction 869 869 CALL iom_put( "veiv_heattr", zztmp * zw3d ) ! heat transport in j-direction … … 880 880 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 881 881 END_3D 882 CALL lbc_lnk( 'ldftra', zw2d, 'U', -1. )883 CALL lbc_lnk( 'ldftra', zw3d, 'U', -1. )882 CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp ) 883 CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp ) 884 884 CALL iom_put( "ueiv_salttr", zztmp * zw2d ) ! salt transport in i-direction 885 885 CALL iom_put( "ueiv_salttr3d", zztmp * zw3d ) ! salt transport in i-direction … … 892 892 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 893 893 END_3D 894 CALL lbc_lnk( 'ldftra', zw2d, 'V', -1. )894 CALL lbc_lnk( 'ldftra', zw2d, 'V', -1.0_wp ) 895 895 CALL iom_put( "veiv_salttr", zztmp * zw2d ) ! salt transport in j-direction 896 896 CALL iom_put( "veiv_salttr", zztmp * zw3d ) ! salt transport in j-direction -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/OBS/ddatetoymdhms.h90
r10068 r13247 21 21 22 22 !! * Arguments 23 real( wp), INTENT(IN) :: ddate23 real(dp), INTENT(IN) :: ddate 24 24 INTEGER, INTENT(OUT) :: kyea 25 25 INTEGER, INTENT(OUT) :: kmon -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/OBS/grt_cir_dis.h90
r10068 r13247 28 28 REAL(KIND=wp) :: pc2 ! cos(lat2) * sin(lon2) 29 29 30 REAL(KIND=wp) :: cosdist ! cosine of great circle distance 31 32 ! Compute cosine of great circle distance, constraining it to be between 33 ! -1 and 1 (rounding errors can take it slightly outside this range 34 cosdist = MAX( MIN( pa1 * pa2 + pb1 * pb2 + pc1 * pc2, 1.0_wp), -1.0_wp ) 35 30 36 grt_cir_dis = & 31 & ASIN( SQRT( 1.0 - ( pa1 * pa2 + pb1 * pb2 + pc1 * pc2 )**2) )37 & ASIN( SQRT( 1.0_wp - cosdist**2.0_wp ) ) 32 38 33 39 END FUNCTION grt_cir_dis -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/OBS/obs_read_prof.F90
r10068 r13247 140 140 & zphi, & 141 141 & zlam 142 REAL( wp), DIMENSION(:), ALLOCATABLE :: &142 REAL(dp), DIMENSION(:), ALLOCATABLE :: & 143 143 & zdat 144 REAL( wp), DIMENSION(knumfiles) :: &144 REAL(dp), DIMENSION(knumfiles) :: & 145 145 & djulini, & 146 146 & djulend -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/OBS/obs_read_surf.F90
r10069 r13247 112 112 & zphi, & 113 113 & zlam 114 REAL( wp), DIMENSION(:), ALLOCATABLE :: &114 REAL(dp), DIMENSION(:), ALLOCATABLE :: & 115 115 & zdat 116 REAL( wp), DIMENSION(knumfiles) :: &116 REAL(dp), DIMENSION(knumfiles) :: & 117 117 & djulini, & 118 118 & djulend -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/OBS/obsinter_z1d.h90
r10068 r13247 62 62 z1dm = ( pdep(kkco(jdep)) - pobsdep(jdep) ) 63 63 z1dp = ( pobsdep(jdep) - pdep(kkco(jdep)-1) ) 64 IF ( pobsmask(kkco(jdep)) == 0.0_wp ) z1dp = 0.0_wp 64 65 ! If kkco(jdep) is masked then set pobs(jdep) to the lowest value located above bathymetry 66 IF ( pobsmask(kkco(jdep)) == 0.0_wp ) THEN 67 pobs(jdep) = pobsk(kkco(jdep)-1) 68 ELSE 69 zsum = z1dm + z1dp 65 70 66 zsum = z1dm + z1dp 67 68 IF ( k1dint == 0 ) THEN 71 IF ( k1dint == 0 ) THEN 69 72 70 !-----------------------------------------------------------------71 ! Linear interpolation72 !-----------------------------------------------------------------73 pobs(jdep) = ( z1dm * pobsk(kkco(jdep)-1) &74 & + z1dp * pobsk(kkco(jdep) ) ) / zsum73 !----------------------------------------------------------------- 74 ! Linear interpolation 75 !----------------------------------------------------------------- 76 pobs(jdep) = ( z1dm * pobsk(kkco(jdep)-1) & 77 & + z1dp * pobsk(kkco(jdep) ) ) / zsum 75 78 76 ELSEIF ( k1dint == 1 ) THEN79 ELSEIF ( k1dint == 1 ) THEN 77 80 78 !-----------------------------------------------------------------79 ! Cubic spline interpolation80 !-----------------------------------------------------------------81 zsum2 = zsum * zsum82 pobs(jdep) = ( z1dm * pobsk (kkco(jdep)-1) &83 & + z1dp * pobsk (kkco(jdep) ) &84 & + ( z1dm * ( z1dm * z1dm - zsum2 ) * pobs2k(kkco(jdep)-1) &85 & + z1dp * ( z1dp * z1dp - zsum2 ) * pobs2k(kkco(jdep) ) &86 & ) / 6.0_wp &87 & ) / zsum81 !----------------------------------------------------------------- 82 ! Cubic spline interpolation 83 !----------------------------------------------------------------- 84 zsum2 = zsum * zsum 85 pobs(jdep) = ( z1dm * pobsk (kkco(jdep)-1) & 86 & + z1dp * pobsk (kkco(jdep) ) & 87 & + ( z1dm * ( z1dm * z1dm - zsum2 ) * pobs2k(kkco(jdep)-1) & 88 & + z1dp * ( z1dp * z1dp - zsum2 ) * pobs2k(kkco(jdep) ) & 89 & ) / 6.0_wp & 90 & ) / zsum 88 91 92 ENDIF 89 93 ENDIF 90 94 END DO -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/SBC/fldread.F90
r12960 r13247 1289 1289 !! D. Delrosso INGV 1290 1290 !!---------------------------------------------------------------------- 1291 INTEGER , INTENT(in ) :: ileni,ilenj ! lengths1292 REAL , DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points1293 REAL , DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field1294 ! 1295 REAL 1296 REAL 1297 REAL 1298 REAL 1299 LOGICAL , DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection1300 LOGICAL , DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection1291 INTEGER , INTENT(in ) :: ileni,ilenj ! lengths 1292 REAL(wp), DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points 1293 REAL(wp), DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field 1294 ! 1295 REAL(wp) , DIMENSION (ileni,ilenj) :: zmat1, zmat2, zmat3, zmat4 ! local arrays 1296 REAL(wp) , DIMENSION (ileni,ilenj) :: zmat5, zmat6, zmat7, zmat8 ! - - 1297 REAL(wp) , DIMENSION (ileni,ilenj) :: zlsm2d ! - - 1298 REAL(wp) , DIMENSION (ileni,ilenj,8) :: zlsm3d ! - - 1299 LOGICAL , DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection 1300 LOGICAL , DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection 1301 1301 !!---------------------------------------------------------------------- 1302 1302 zmat8 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(:,1)/) , DIM=2 ) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/SBC/geo2ocean.F90
r12377 r13247 272 272 ! =========================== ! 273 273 ! ! lateral boundary cond.: T-, U-, V-, F-pts, sgn 274 CALL lbc_lnk_multi( 'geo2ocean', gcost, 'T', -1. , gsint, 'T', -1., gcosu, 'U', -1., gsinu, 'U', -1., &275 & gcosv, 'V', -1. , gsinv, 'V', -1., gcosf, 'F', -1., gsinf, 'F', -1.)274 CALL lbc_lnk_multi( 'geo2ocean', gcost, 'T', -1.0_wp, gsint, 'T', -1.0_wp, gcosu, 'U', -1.0_wp, gsinu, 'U', -1.0_wp, & 275 & gcosv, 'V', -1.0_wp, gsinv, 'V', -1.0_wp, gcosf, 'F', -1.0_wp, gsinf, 'F', -1.0_wp ) 276 276 ! 277 277 END SUBROUTINE angle -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/SBC/sbc_oce.F90
r12377 r13247 223 223 wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1) 224 224 END_2D 225 CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1. )225 CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1.0_wp ) 226 226 ! 227 227 END SUBROUTINE sbc_tau2wnd -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/SBC/sbcblk.F90
r13229 r13247 971 971 pvtaui(ji,jj) = zztmp2 * ( pvtaui(ji,jj) + pvtaui(ji ,jj+1) ) 972 972 END_2D 973 CALL lbc_lnk_multi( 'sbcblk', putaui, 'U', -1. , pvtaui, 'V', -1.)973 CALL lbc_lnk_multi( 'sbcblk', putaui, 'U', -1._wp, pvtaui, 'V', -1._wp ) 974 974 ! 975 975 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=putaui , clinfo1=' blk_ice: putaui : ' & … … 1439 1439 ! 1440 1440 END_2D 1441 CALL lbc_lnk_multi( 'sbcblk', pcd, 'T', 1. , pch, 'T', 1.)1441 CALL lbc_lnk_multi( 'sbcblk', pcd, 'T', 1.0_wp, pch, 'T', 1.0_wp ) 1442 1442 ! 1443 1443 END SUBROUTINE Cdn10_Lupkes2015 -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/SBC/sbccpl.F90
r13124 r13247 1173 1173 frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) 1174 1174 END_2D 1175 CALL lbc_lnk_multi( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1. , frcv(jpr_oty1)%z3(:,:,1), 'V', -1.)1175 CALL lbc_lnk_multi( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1.0_wp, frcv(jpr_oty1)%z3(:,:,1), 'V', -1.0_wp ) 1176 1176 ENDIF 1177 1177 llnewtx = .TRUE. … … 1198 1198 frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) 1199 1199 END_2D 1200 CALL lbc_lnk( 'sbccpl', frcv(jpr_taum)%z3(:,:,1), 'T', 1. )1200 CALL lbc_lnk( 'sbccpl', frcv(jpr_taum)%z3(:,:,1), 'T', 1.0_wp ) 1201 1201 llnewtau = .TRUE. 1202 1202 ELSE … … 2375 2375 zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2376 2376 END_2D 2377 CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1. , zity1, 'T', -1.)2377 CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) 2378 2378 CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T 2379 2379 DO_2D_00_00 … … 2384 2384 END_2D 2385 2385 END SELECT 2386 CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1. , zoty1, ssnd(jps_ocy1)%clgrid, -1.)2386 CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp ) 2387 2387 ! 2388 2388 ENDIF … … 2452 2452 zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2453 2453 END_2D 2454 CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1. , zity1, 'T', -1.)2454 CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) 2455 2455 CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T 2456 2456 DO_2D_00_00 … … 2461 2461 END_2D 2462 2462 END SELECT 2463 CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1. , zoty1, ssnd(jps_ocyw)%clgrid, -1.)2463 CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp ) 2464 2464 ! 2465 2465 ! -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/SBC/sbcflx.F90
r12377 r13247 151 151 END_2D 152 152 taum(:,:) = taum(:,:) * tmask(:,:,1) ; wndm(:,:) = wndm(:,:) * tmask(:,:,1) 153 CALL lbc_lnk( 'sbcflx', taum(:,:), 'T', 1. ) ; CALL lbc_lnk( 'sbcflx', wndm(:,:), 'T', 1.)153 CALL lbc_lnk( 'sbcflx', taum(:,:), 'T', 1.0_wp ) ; CALL lbc_lnk( 'sbcflx', wndm(:,:), 'T', 1.0_wp ) 154 154 155 155 IF( nitend-nit000 <= 100 .AND. lwp ) THEN ! control print (if less than 100 time-step asked) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/SBC/sbcfwb.F90
r13176 r13247 71 71 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_tospread, zerp_cor ! - - 72 72 REAL(wp) ,DIMENSION(1) :: z_fwfprv 73 COMPLEX( wp),DIMENSION(1) :: y_fwfnow73 COMPLEX(dp),DIMENSION(1) :: y_fwfnow 74 74 !!---------------------------------------------------------------------- 75 75 ! … … 180 180 ! 181 181 !!gm ===>>>> lbc_lnk should be useless as all the computation is done over the whole domain ! 182 CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1. )182 CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1.0_wp ) 183 183 ! 184 184 emp(:,:) = emp(:,:) + zerp_cor(:,:) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/SBC/sbcice_cice.F90
r12807 r13247 218 218 END_2D 219 219 220 CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1. , fr_iv , 'V', 1.)220 CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp ) 221 221 222 222 ! set the snow+ice mass … … 498 498 ss_iou(ji,jj) = 0.5 * ( ztmp1(ji,jj-1) + ztmp1(ji,jj) ) * umask(ji,jj,1) 499 499 END_2D 500 CALL lbc_lnk( 'sbcice_cice', ss_iou , 'U', -1. )500 CALL lbc_lnk( 'sbcice_cice', ss_iou , 'U', -1.0_wp ) 501 501 502 502 ! y comp of ocean-ice stress … … 508 508 ss_iov(ji,jj) = 0.5 * ( ztmp1(ji-1,jj) + ztmp1(ji,jj) ) * vmask(ji,jj,1) 509 509 END_2D 510 CALL lbc_lnk( 'sbcice_cice', ss_iov , 'V', -1. )510 CALL lbc_lnk( 'sbcice_cice', ss_iov , 'V', -1.0_wp ) 511 511 512 512 ! x and y comps of surface stress … … 561 561 fmmflx(:,:) = ztmp1(:,:) !!Joakim edit 562 562 563 CALL lbc_lnk_multi( 'sbcice_cice', emp , 'T', 1. , sfx , 'T', 1.)563 CALL lbc_lnk_multi( 'sbcice_cice', emp , 'T', 1.0_wp, sfx , 'T', 1.0_wp ) 564 564 565 565 ! Solar penetrative radiation and non solar surface heat flux … … 587 587 #endif 588 588 qsr(:,:)=qsr(:,:)+ztmp1(:,:) 589 CALL lbc_lnk( 'sbcice_cice', qsr , 'T', 1. )589 CALL lbc_lnk( 'sbcice_cice', qsr , 'T', 1.0_wp ) 590 590 591 591 DO_2D_11_11 … … 600 600 qns(:,:)=qns(:,:)+nfrzmlt(:,:)+ztmp1(:,:) 601 601 602 CALL lbc_lnk( 'sbcice_cice', qns , 'T', 1. )602 CALL lbc_lnk( 'sbcice_cice', qns , 'T', 1.0_wp ) 603 603 604 604 ! Prepare for the following CICE time-step … … 618 618 END_2D 619 619 620 CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1. , fr_iv , 'V', 1.)620 CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp ) 621 621 622 622 ! set the snow+ice mass -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/SBC/sbcmod.F90
r13229 r13247 461 461 ! A lbc_lnk is therefore needed to ensure reproducibility and restartability. 462 462 ! see ticket #2113 for discussion about this lbc_lnk. 463 IF( .NOT. ln_passive_mode ) CALL lbc_lnk( 'sbcmod', emp, 'T', 1. ) ! ensure restartability with icebergs463 IF( .NOT. ln_passive_mode ) CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp ) ! ensure restartability with icebergs 464 464 ENDIF 465 465 … … 476 476 !!$!RBbug do not understand why see ticket 667 477 477 !!$!clem: it looks like it is necessary for the north fold (in certain circumstances). Don't know why. 478 !!$ CALL lbc_lnk( 'sbcmod', emp, 'T', 1. )478 !!$ CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp ) 479 479 IF( ll_wd ) THEN ! If near WAD point limit the flux for now 480 480 zthscl = atanh(rn_wd_sbcfra) ! taper frac default is .999 -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/SBC/sbcssr.F90
r12377 r13247 131 131 & * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) & 132 132 & / MAX( sss_m(ji,jj), 1.e-20 ) * tmask(ji,jj,1) 133 IF( ln_sssr_bnd ) zerp = SIGN( 1. , zerp ) * MIN( zerp_bnd, ABS(zerp) )133 IF( ln_sssr_bnd ) zerp = SIGN( 1.0_wp, zerp ) * MIN( zerp_bnd, ABS(zerp) ) 134 134 emp(ji,jj) = emp (ji,jj) + zerp 135 135 qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/SBC/sbcwave.F90
r12980 r13247 198 198 ENDIF 199 199 200 CALL lbc_lnk_multi( 'sbcwave', usd, 'U', -1. , vsd, 'V', -1.)200 CALL lbc_lnk_multi( 'sbcwave', usd, 'U', -1.0_wp, vsd, 'V', -1.0_wp ) 201 201 202 202 ! … … 210 210 END_3D 211 211 ! 212 CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1. )212 CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1.0_wp ) 213 213 ! 214 214 IF( ln_linssh ) THEN ; ik = 1 ! none zero velocity through the sea surface … … 269 269 taum(ji,jj) = SQRT( tauw_x(ji,jj)*tauw_x(ji,jj) + tauw_y(ji,jj)*tauw_y(ji,jj) ) 270 270 END_2D 271 CALL lbc_lnk_multi( 'sbcwave', utau(:,:), 'U', -1. , vtau(:,:), 'V', -1. , taum(:,:) , 'T', -1.)271 CALL lbc_lnk_multi( 'sbcwave', utau(:,:), 'U', -1.0_wp , vtau(:,:), 'V', -1.0_wp , taum(:,:) , 'T', -1.0_wp ) 272 272 ENDIF 273 273 ! -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/STO/stopar.F90
r13229 r13247 687 687 INTEGER :: idg ! number of digits 688 688 INTEGER(KIND=8) :: ziseed(4) ! RNG seeds in integer type 689 REAL(KIND= 8) :: zrseed(4) ! RNG seeds in real type(with same bits to save in restart)689 REAL(KIND=dp) :: zrseed(4) ! RNG seeds in double-precision (with same bits to save in restart) 690 690 CHARACTER(LEN=9) :: clsto2d='sto2d_000' ! stochastic parameter variable name 691 691 CHARACTER(LEN=9) :: clsto3d='sto3d_000' ! stochastic parameter variable name … … 749 749 INTEGER :: idg ! number of digits 750 750 INTEGER(KIND=8) :: ziseed(4) ! RNG seeds in integer type 751 REAL(KIND= 8) :: zrseed(4) ! RNG seeds in real type(with same bits to save in restart)751 REAL(KIND=dp) :: zrseed(4) ! RNG seeds in double-precision (with same bits to save in restart) 752 752 CHARACTER(LEN=20) :: clkt ! ocean time-step defined as a character 753 753 CHARACTER(LEN=50) :: clname ! restart file name … … 835 835 !! 836 836 INTEGER :: ji, jj 837 REAL( KIND=8) :: gran ! Gaussian random number (forced KIND=8 as in kiss_gaussian)837 REAL(wp) :: gran ! Gaussian random number (forced KIND=8 as in kiss_gaussian) 838 838 839 839 DO_2D_11_11 -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TDE/tide_mod.F90
r12738 r13247 723 723 !! ** Action : pot_astro actronomical potential 724 724 !!---------------------------------------------------------------------- 725 REAL , INTENT(in):: pdelta ! Temporal offset in seconds725 REAL(wp), INTENT(in) :: pdelta ! Temporal offset in seconds 726 726 INTEGER, INTENT(IN) :: Kmm ! Time level index 727 727 INTEGER :: jk ! Dummy loop index -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/traadv_cen.F90
r12377 r13247 115 115 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 116 116 END_3D 117 CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1. , ztv, 'V', -1.) ! Lateral boundary cond.117 CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. 118 118 ! 119 119 DO_3D_00_10( 1, jpkm1 ) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/traadv_fct.F90
r12866 r13247 96 96 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 97 97 ENDIF 98 !! -- init to 0 99 zwi(:,:,:) = 0._wp 100 zwx(:,:,:) = 0._wp 101 zwy(:,:,:) = 0._wp 102 zwz(:,:,:) = 0._wp 103 ztu(:,:,:) = 0._wp 104 ztv(:,:,:) = 0._wp 105 zltu(:,:,:) = 0._wp 106 zltv(:,:,:) = 0._wp 107 ztw(:,:,:) = 0._wp 98 108 ! 99 109 l_trd = .FALSE. ! set local switches … … 222 232 END_2D 223 233 END DO 224 CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1. , zltv, 'T', 1.) ! Lateral boundary cond. (unchanged sgn)234 CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 225 235 ! 226 236 DO_3D_10_10( 1, jpkm1 ) … … 239 249 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 240 250 END_3D 241 CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1. , ztv, 'V', -1.) ! Lateral boundary cond. (unchanged sgn)251 CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 242 252 ! 243 253 DO_3D_00_00( 1, jpkm1 ) … … 291 301 END IF 292 302 ! 293 CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1. , zwx, 'U', -1. , zwy, 'V', -1., zwz, 'W', 1.)303 CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'W', 1.0_wp ) 294 304 ! 295 305 ! !== monotonicity algorithm ==! … … 376 386 INTEGER :: ji, jj, jk ! dummy loop indices 377 387 INTEGER :: ikm1 ! local integer 378 REAL( wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars379 REAL( wp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - -380 REAL( wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo381 !!---------------------------------------------------------------------- 382 ! 383 zbig = 1.e+40_ wp384 zrtrn = 1.e-15_ wp385 zbetup(:,:,:) = 0._ wp ; zbetdo(:,:,:) = 0._wp388 REAL(dp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars 389 REAL(dp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - 390 REAL(dp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo 391 !!---------------------------------------------------------------------- 392 ! 393 zbig = 1.e+40_dp 394 zrtrn = 1.e-15_dp 395 zbetup(:,:,:) = 0._dp ; zbetdo(:,:,:) = 0._dp 386 396 387 397 ! Search local extrema … … 425 435 END_2D 426 436 END DO 427 CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1. , zbetdo, 'T', 1.) ! lateral boundary cond. (unchanged sign)437 CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign) 428 438 429 439 ! 3. monotonic flux in the i & j direction (paa & pbb) … … 432 442 zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 433 443 zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 434 zcu = ( 0.5 + SIGN( 0.5 , paa(ji,jj,jk) ) )444 zcu = ( 0.5 + SIGN( 0.5_wp , paa(ji,jj,jk) ) ) 435 445 paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) 436 446 437 447 zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) 438 448 zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) 439 zcv = ( 0.5 + SIGN( 0.5 , pbb(ji,jj,jk) ) )449 zcv = ( 0.5 + SIGN( 0.5_wp , pbb(ji,jj,jk) ) ) 440 450 pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 441 451 … … 444 454 za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) 445 455 zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 446 zc = ( 0.5 + SIGN( 0.5 , pcc(ji,jj,jk+1) ) )456 zc = ( 0.5 + SIGN( 0.5_wp , pcc(ji,jj,jk+1) ) ) 447 457 pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 448 458 END_3D 449 CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1. , pbb, 'V', -1.) ! lateral boundary condition (changed sign)459 CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1.0_wp , pbb, 'V', -1.0_wp ) ! lateral boundary condition (changed sign) 450 460 ! 451 461 END SUBROUTINE nonosc -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/traadv_mus.F90
r12810 r13247 136 136 END_3D 137 137 ! lateral boundary conditions (changed sign) 138 CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1.)138 CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) 139 139 ! !-- Slopes of tracer 140 140 zslpx(:,:,jpk) = 0._wp ! bottom values 141 141 zslpy(:,:,jpk) = 0._wp 142 142 DO_3D_01_01( 1, jpkm1 ) 143 zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) &144 & * ( 0.25 + SIGN( 0.25 , zwx(ji,jj,jk) * zwx(ji-1,jj ,jk) ) )145 zslpy(ji,jj,jk) = ( zwy(ji,jj,jk) + zwy(ji ,jj-1,jk) ) &146 & * ( 0.25 + SIGN( 0.25 , zwy(ji,jj,jk) * zwy(ji ,jj-1,jk) ) )143 zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) & 144 & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji-1,jj ,jk) ) ) 145 zslpy(ji,jj,jk) = ( zwy(ji,jj,jk) + zwy(ji ,jj-1,jk) ) & 146 & * ( 0.25 + SIGN( 0.25_wp, zwy(ji,jj,jk) * zwy(ji ,jj-1,jk) ) ) 147 147 END_3D 148 148 ! 149 149 DO_3D_01_01( 1, jpkm1 ) 150 zslpx(ji,jj,jk) = SIGN( 1. , zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), &151 & 2.*ABS( zwx (ji-1,jj,jk) ), &152 & 2.*ABS( zwx (ji ,jj,jk) ) )153 zslpy(ji,jj,jk) = SIGN( 1. , zslpy(ji,jj,jk) ) * MIN( ABS( zslpy(ji,jj ,jk) ), &154 & 2.*ABS( zwy (ji,jj-1,jk) ), &155 & 2.*ABS( zwy (ji,jj ,jk) ) )150 zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), & 151 & 2.*ABS( zwx (ji-1,jj,jk) ), & 152 & 2.*ABS( zwx (ji ,jj,jk) ) ) 153 zslpy(ji,jj,jk) = SIGN( 1.0_wp, zslpy(ji,jj,jk) ) * MIN( ABS( zslpy(ji,jj ,jk) ), & 154 & 2.*ABS( zwy (ji,jj-1,jk) ), & 155 & 2.*ABS( zwy (ji,jj ,jk) ) ) 156 156 END_3D 157 157 ! 158 158 DO_3D_00_00( 1, jpkm1 ) 159 159 ! MUSCL fluxes 160 z0u = SIGN( 0.5 , pU(ji,jj,jk) )160 z0u = SIGN( 0.5_wp, pU(ji,jj,jk) ) 161 161 zalpha = 0.5 - z0u 162 162 zu = z0u - 0.5 * pU(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) … … 165 165 zwx(ji,jj,jk) = pU(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 166 166 ! 167 z0v = SIGN( 0.5 , pV(ji,jj,jk) )167 z0v = SIGN( 0.5_wp, pV(ji,jj,jk) ) 168 168 zalpha = 0.5 - z0v 169 169 zv = z0v - 0.5 * pV(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) … … 172 172 zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 173 173 END_3D 174 CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1.) ! lateral boundary conditions (changed sign)174 CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! lateral boundary conditions (changed sign) 175 175 ! 176 176 DO_3D_00_00( 1, jpkm1 ) … … 200 200 zslpx(:,:,1) = 0._wp ! surface values 201 201 DO_3D_11_11( 2, jpkm1 ) 202 zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) &203 & * ( 0.25 + SIGN( 0.25 , zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) )202 zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) & 203 & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) 204 204 END_3D 205 205 DO_3D_11_11( 2, jpkm1 ) 206 zslpx(ji,jj,jk) = SIGN( 1. , zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), &207 & 2.*ABS( zwx (ji,jj,jk+1) ), &208 & 2.*ABS( zwx (ji,jj,jk ) ) )206 zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), & 207 & 2.*ABS( zwx (ji,jj,jk+1) ), & 208 & 2.*ABS( zwx (ji,jj,jk ) ) ) 209 209 END_3D 210 210 DO_3D_00_00( 1, jpk-2 ) 211 z0w = SIGN( 0.5 , pW(ji,jj,jk+1) )211 z0w = SIGN( 0.5_wp, pW(ji,jj,jk+1) ) 212 212 zalpha = 0.5 + z0w 213 213 zw = z0w - 0.5 * pW(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w(ji,jj,jk+1,Kmm) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/traadv_qck.F90
r12377 r13247 145 145 zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer 146 146 END_3D 147 CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1.) ! Lateral boundary conditions147 CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 148 148 149 149 ! … … 151 151 ! --------------------------- 152 152 DO_3D_00_00( 1, jpkm1 ) 153 zdir = 0.5 + SIGN( 0.5 , pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0153 zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 154 154 zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk) ! FU in the x-direction for T 155 155 END_3D 156 156 ! 157 157 DO_3D_00_00( 1, jpkm1 ) 158 zdir = 0.5 + SIGN( 0.5 , pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0158 zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 159 159 zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 160 160 zwx(ji,jj,jk) = ABS( pU(ji,jj,jk) ) * p2dt / zdx ! (0<zc_cfl<1 : Courant number on x-direction) … … 163 163 END_3D 164 164 !--- Lateral boundary conditions 165 CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1., zwx(:,:,:), 'T', 1.)165 CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwx(:,:,:), 'T', 1.0_wp ) 166 166 167 167 !--- QUICKEST scheme … … 172 172 zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 173 173 END_3D 174 CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. ) ! Lateral boundary conditions174 CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 175 175 176 176 ! … … 179 179 ! 180 180 DO_2D_00_00 181 zdir = 0.5 + SIGN( 0.5 , pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0181 zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 182 182 !--- If the second ustream point is a land point 183 183 !--- the flux is computed by the 1st order UPWIND scheme … … 188 188 END DO 189 189 ! 190 CALL lbc_lnk( 'traadv_qck', zwx(:,:,:), 'T', 1. ) ! Lateral boundary conditions190 CALL lbc_lnk( 'traadv_qck', zwx(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 191 191 ! 192 192 ! Computation of the trend … … 239 239 END_2D 240 240 END DO 241 CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1.) ! Lateral boundary conditions241 CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 242 242 243 243 … … 247 247 ! 248 248 DO_3D_00_00( 1, jpkm1 ) 249 zdir = 0.5 + SIGN( 0.5 , pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0249 zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 250 250 zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk) ! FU in the x-direction for T 251 251 END_3D 252 252 ! 253 253 DO_3D_00_00( 1, jpkm1 ) 254 zdir = 0.5 + SIGN( 0.5 , pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0254 zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 255 255 zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 256 256 zwy(ji,jj,jk) = ABS( pV(ji,jj,jk) ) * p2dt / zdx ! (0<zc_cfl<1 : Courant number on x-direction) … … 260 260 261 261 !--- Lateral boundary conditions 262 CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1., zwy(:,:,:), 'T', 1.)262 CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp ) 263 263 264 264 !--- QUICKEST scheme … … 269 269 zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 270 270 END_3D 271 CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. ) !--- Lateral boundary conditions271 CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp ) !--- Lateral boundary conditions 272 272 ! 273 273 ! Tracer flux on the x-direction … … 275 275 ! 276 276 DO_2D_00_00 277 zdir = 0.5 + SIGN( 0.5 , pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0277 zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 278 278 !--- If the second ustream point is a land point 279 279 !--- the flux is computed by the 1st order UPWIND scheme … … 284 284 END DO 285 285 ! 286 CALL lbc_lnk( 'traadv_qck', zwy(:,:,:), 'T', 1. ) ! Lateral boundary conditions286 CALL lbc_lnk( 'traadv_qck', zwy(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 287 287 ! 288 288 ! Computation of the trend -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/traadv_ubs.F90
r12377 r13247 137 137 ! 138 138 END DO 139 CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1. ) ; CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1.) ! Lateral boundary cond. (unchanged sgn)139 CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp ) ; CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 140 140 ! 141 141 DO_3D_10_10( 1, jpkm1 ) … … 206 206 zti(ji,jj,jk) = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 207 207 END_3D 208 CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1. ) ! Lateral boundary conditions on zti, zsi (unchanged sign)208 CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1.0_wp ) ! Lateral boundary conditions on zti, zsi (unchanged sign) 209 209 ! 210 210 ! !* anti-diffusive flux : high order minus low order … … 270 270 !!---------------------------------------------------------------------- 271 271 ! 272 zbig = 1.e+ 40_wp272 zbig = 1.e+38_wp 273 273 zrtrn = 1.e-15_wp 274 274 zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp … … 321 321 za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) ) 322 322 zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) ) 323 zc = 0.5 * ( 1.e0 + SIGN( 1. e0, pcc(ji,jj,jk) ) )323 zc = 0.5 * ( 1.e0 + SIGN( 1.0_wp, pcc(ji,jj,jk) ) ) 324 324 pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb ) 325 325 END_3D -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/traatf.F90
r12489 r13247 109 109 #endif 110 110 ! ! local domain boundaries (T-point, unchanged sign) 111 CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kaa), 'T', 1. , pts(:,:,:,jp_sal,Kaa), 'T', 1.)111 CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp ) 112 112 ! 113 113 IF( ln_bdy ) CALL bdy_tra( kt, Kbb, pts, Kaa ) ! BDY open boundaries … … 155 155 ENDIF 156 156 ! 157 CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kbb) , 'T', 1. , pts(:,:,:,jp_sal,Kbb) , 'T', 1., &158 & pts(:,:,:,jp_tem,Kmm) , 'T', 1. , pts(:,:,:,jp_sal,Kmm) , 'T', 1., &159 & pts(:,:,:,jp_tem,Kaa), 'T', 1. , pts(:,:,:,jp_sal,Kaa), 'T', 1.)157 CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kbb) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kbb) , 'T', 1.0_wp, & 158 & pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp, & 159 & pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp ) 160 160 ! 161 161 ENDIF -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/trabbc.F90
r12489 r13247 94 94 END_2D 95 95 ! 96 CALL lbc_lnk( 'trabbc', pts(:,:,:,jp_tem,Krhs) , 'T', 1. )96 CALL lbc_lnk( 'trabbc', pts(:,:,:,jp_tem,Krhs) , 'T', 1.0_wp ) 97 97 ! 98 98 IF( l_trdtra ) THEN ! Send the trend for diagnostics -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/trabbl.F90
r12377 r13247 125 125 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 126 126 ! lateral boundary conditions ; just need for outputs 127 CALL lbc_lnk_multi( 'trabbl', ahu_bbl, 'U', 1. , ahv_bbl, 'V', 1.)127 CALL lbc_lnk_multi( 'trabbl', ahu_bbl, 'U', 1.0_wp , ahv_bbl, 'V', 1.0_wp ) 128 128 CALL iom_put( "ahu_bbl", ahu_bbl ) ! bbl diffusive flux i-coef 129 129 CALL iom_put( "ahv_bbl", ahv_bbl ) ! bbl diffusive flux j-coef … … 138 138 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 139 139 ! lateral boundary conditions ; just need for outputs 140 CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1. , vtr_bbl, 'V', 1.)140 CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 141 141 CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport 142 142 CALL iom_put( "voce_bbl", vtr_bbl ) ! bbl j-transport … … 365 365 & - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) 366 366 ! 367 zsign = SIGN( 0.5 , -zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of ( i-gradient * i-slope )367 zsign = SIGN( 0.5_wp, -zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of ( i-gradient * i-slope ) 368 368 ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj) ! masked diffusive flux coeff. 369 369 ! … … 375 375 & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) 376 376 ! 377 zsign = SIGN( 0.5 , -zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of ( j-gradient * j-slope )377 zsign = SIGN( 0.5_wp, -zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of ( j-gradient * j-slope ) 378 378 ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 379 379 END_2D … … 395 395 - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) 396 396 ! 397 zsign = SIGN( 0.5 , - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope398 zsigna= SIGN( 0.5 , zub(ji,jj) * REAL( mgrhu(ji,jj) ) ) ! sign of u * i-slope397 zsign = SIGN( 0.5_wp, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope 398 zsigna= SIGN( 0.5_wp, zub(ji,jj) * REAL( mgrhu(ji,jj) ) ) ! sign of u * i-slope 399 399 ! 400 400 ! ! bbl velocity … … 407 407 zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & 408 408 & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) 409 zsign = SIGN( 0.5 , - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope410 zsigna= SIGN( 0.5 , zvb(ji,jj) * REAL( mgrhv(ji,jj) ) ) ! sign of u * i-slope409 zsign = SIGN( 0.5_wp, - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope 410 zsigna= SIGN( 0.5_wp, zvb(ji,jj) * REAL( mgrhv(ji,jj) ) ) ! sign of u * i-slope 411 411 ! 412 412 ! ! bbl transport … … 514 514 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 515 515 zmbku(:,:) = REAL( mbku_d(:,:), wp ) ; zmbkv(:,:) = REAL( mbkv_d(:,:), wp ) 516 CALL lbc_lnk_multi( 'trabbl', zmbku,'U',1. , zmbkv,'V',1.)516 CALL lbc_lnk_multi( 'trabbl', zmbku,'U',1.0_wp, zmbkv,'V',1.0_wp) 517 517 mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ; mbkv_d(:,:) = MAX( NINT( zmbkv(:,:) ), 1 ) 518 518 ! … … 521 521 DO_2D_10_10 522 522 IF( gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN 523 mgrhu(ji,jj) = INT( SIGN( 1. e0, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) ) )523 mgrhu(ji,jj) = INT( SIGN( 1.0_wp, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) ) ) 524 524 ENDIF 525 525 ! 526 526 IF( gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN 527 mgrhv(ji,jj) = INT( SIGN( 1. e0, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) ) )527 mgrhv(ji,jj) = INT( SIGN( 1.0_wp, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) ) ) 528 528 ENDIF 529 529 END_2D … … 533 533 e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 534 534 END_2D 535 CALL lbc_lnk_multi( 'trabbl', e3u_bbl_0, 'U', 1. , e3v_bbl_0, 'V', 1.) ! lateral boundary conditions535 CALL lbc_lnk_multi( 'trabbl', e3u_bbl_0, 'U', 1.0_wp , e3v_bbl_0, 'V', 1.0_wp ) ! lateral boundary conditions 536 536 ! 537 537 ! !* masked diffusive flux coefficients -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/traldf_lap_blp.F90
r12377 r13247 199 199 END SELECT 200 200 ! 201 CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1. ) ! Lateral boundary conditions (unchanged sign)201 CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1.0_wp ) ! Lateral boundary conditions (unchanged sign) 202 202 ! ! Partial top/bottom cell: GRADh( zlap ) 203 203 IF( ln_isfcav .AND. ln_zps ) THEN ; CALL zps_hde_isf( kt, Kmm, kjpt, zlap, zglu, zglv, zgui, zgvi ) ! both top & bottom -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/tramle.F90
r12489 r13247 288 288 rfv(ji,jj) = SQRT( zfv * zfv + z1_t2 ) 289 289 END_2D 290 CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1. , rfv, 'V', 1.)290 CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) 291 291 ! 292 292 ELSEIF( nn_mle == 1 ) THEN ! MLE array allocation & initialisation -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/tranpc.F90
r12489 r13247 309 309 ENDIF 310 310 ! 311 CALL lbc_lnk_multi( 'tranpc', pts(:,:,:,jp_tem,Kaa), 'T', 1. , pts(:,:,:,jp_sal,Kaa), 'T', 1.)311 CALL lbc_lnk_multi( 'tranpc', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp ) 312 312 ! 313 313 IF( lwp .AND. l_LB_debug ) THEN -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/trazdf.F90
r12489 r13247 90 90 END DO 91 91 !!gm this should be moved in trdtra.F90 and done on all trends 92 CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1. , ztrds, 'T', 1.)92 CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) 93 93 !!gm 94 94 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_zdf, ztrdt ) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRA/zpshde.F90
r12377 r13247 145 145 END DO 146 146 ! 147 CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1. , pgtv(:,:,:), 'V', -1.) ! Lateral boundary cond.147 CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. 148 148 ! 149 149 IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) … … 178 178 ENDIF 179 179 END_2D 180 CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1. , pgrv , 'V', -1.) ! Lateral boundary conditions180 CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions 181 181 ! 182 182 END IF … … 301 301 END DO 302 302 ! 303 CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1. , pgtv(:,:,:), 'V', -1.) ! Lateral boundary cond.303 CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. 304 304 305 305 ! horizontal derivative of density anomalies (rd) … … 343 343 END_2D 344 344 345 CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1. , pgrv , 'V', -1.) ! Lateral boundary conditions345 CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions 346 346 ! 347 347 END IF … … 394 394 ! 395 395 END DO 396 CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1. , pgtvi(:,:,:), 'V', -1.) ! Lateral boundary cond.396 CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. 397 397 398 398 IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) … … 433 433 434 434 END_2D 435 CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1. , pgrvi, 'V', -1.) ! Lateral boundary conditions435 CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions 436 436 ! 437 437 END IF -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRD/trddyn.F90
r12489 r13247 127 127 z3dy(ji,jj,jk) = vv(ji,jj,jk,Kmm) * ( vv(ji,jj+1,jk,Kmm) - vv(ji,jj-1,jk,Kmm) ) / ( 2._wp * e2v(ji,jj) ) 128 128 END_3D 129 CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1. , z3dy, 'V', -1.)129 CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) 130 130 CALL iom_put( "utrd_udx", z3dx ) 131 131 CALL iom_put( "vtrd_vdy", z3dy ) … … 163 163 ! END DO 164 164 ! END DO 165 ! CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1. , z3dy, 'V', -1.)165 ! CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) 166 166 ! CALL iom_put( "utrd_bfr", z3dx ) 167 167 ! CALL iom_put( "vtrd_bfr", z3dy ) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRD/trdken.F90
r12489 r13247 89 89 !!---------------------------------------------------------------------- 90 90 ! 91 CALL lbc_lnk_multi( 'trdken', putrd, 'U', -1. , pvtrd, 'V', -1.) ! lateral boundary conditions91 CALL lbc_lnk_multi( 'trdken', putrd, 'U', -1.0_wp , pvtrd, 'V', -1.0_wp ) ! lateral boundary conditions 92 92 ! 93 93 nkstp = kt -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRD/trdmxl.F90
r12377 r13247 151 151 !!gm to be put juste before the output ! 152 152 ! ! Lateral boundary conditions 153 ! CALL lbc_lnk_multi( 'trdmxl', tmltrd(:,:,jl), 'T', 1. , smltrd(:,:,jl), 'T', 1.)153 ! CALL lbc_lnk_multi( 'trdmxl', tmltrd(:,:,jl), 'T', 1.0_wp , smltrd(:,:,jl), 'T', 1.0_wp ) 154 154 !!gm end 155 155 … … 469 469 !-- Lateral boundary conditions 470 470 ! ... temperature ... ... salinity ... 471 CALL lbc_lnk_multi( 'trdmxl', ztmltot , 'T', 1. , zsmltot , 'T', 1., &472 & ztmlres , 'T', 1. , zsmlres , 'T', 1., &473 & ztmlatf , 'T', 1. , zsmlatf , 'T', 1.)471 CALL lbc_lnk_multi( 'trdmxl', ztmltot , 'T', 1.0_wp, zsmltot , 'T', 1.0_wp, & 472 & ztmlres , 'T', 1.0_wp, zsmlres , 'T', 1.0_wp, & 473 & ztmlatf , 'T', 1.0_wp, zsmlatf , 'T', 1.0_wp ) 474 474 475 475 … … 520 520 !-- Lateral boundary conditions 521 521 ! ... temperature ... ... salinity ... 522 CALL lbc_lnk_multi( 'trdmxl', ztmltot2, 'T', 1. , zsmltot2, 'T', 1., &523 & ztmlres2, 'T', 1. , zsmlres2, 'T', 1.)524 ! 525 CALL lbc_lnk_multi( 'trdmxl', ztmltrd2(:,:,:), 'T', 1. , zsmltrd2(:,:,:), 'T', 1.) ! / in the NetCDF trends file522 CALL lbc_lnk_multi( 'trdmxl', ztmltot2, 'T', 1.0_wp, zsmltot2, 'T', 1.0_wp, & 523 & ztmlres2, 'T', 1.0_wp, zsmlres2, 'T', 1.0_wp ) 524 ! 525 CALL lbc_lnk_multi( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_wp, zsmltrd2(:,:,:), 'T', 1.0_wp ) ! / in the NetCDF trends file 526 526 527 527 ! III.3 Time evolution array swap -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRD/trdtrc.F90
r12377 r13247 1 1 MODULE trdtrc 2 USE par_kind 2 3 !!====================================================================== 3 4 !! *** MODULE trdtrc *** … … 12 13 INTEGER :: kt, kjn, ktrd 13 14 INTEGER :: Kmm ! time level index 14 REAL 15 REAL(wp):: ptrtrd(:,:,:) 15 16 WRITE(*,*) 'trd_trc : You should not have seen this print! error?', ptrtrd(1,1,1) 16 17 WRITE(*,*) ' " " : You should not have seen this print! error?', kjn, ktrd, kt -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/TRD/trdvor.F90
r12489 r13247 161 161 162 162 zudpvor(:,:) = 0._wp ; zvdpvor(:,:) = 0._wp ! Initialisation 163 CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1. , pvtrdvor, 'V', -1.) ! lateral boundary condition163 CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp ) ! lateral boundary condition 164 164 165 165 … … 249 249 zvdpvor(:,:) = 0._wp 250 250 ! ! lateral boundary condition on input momentum trends 251 CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1. , pvtrdvor, 'V', -1.)251 CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp ) 252 252 253 253 ! ===================================== … … 395 395 396 396 ! Boundary conditions 397 CALL lbc_lnk_multi( 'trdvor', vor_avrtot, 'F', 1. , vor_avrres, 'F', 1.)397 CALL lbc_lnk_multi( 'trdvor', vor_avrtot, 'F', 1.0_wp , vor_avrres, 'F', 1.0_wp ) 398 398 399 399 -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/USR/usrdef_nam.F90
r13238 r13247 69 69 kk_cfg = nn_GYRE 70 70 ! 71 IF( Agrif_Root() ) THEN ! Global Domain size: add 1 land point on each side72 kpi = 30 * nn_GYRE + 2 !73 kpj = 20 * nn_GYRE + 2 74 ELSE ! Global Domain size: add nbghostcells + 1 "land"point on each side71 kpi = 30 * nn_GYRE + 2 ! 72 kpj = 20 * nn_GYRE + 2 73 #if defined key_agrif 74 IF( .NOT.Agrif_Root() ) THEN ! Global Domain size: add 1 land point on each side 75 75 kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2 76 76 kpj = nbcellsy + nbghostcells_y_s + nbghostcells_y_n + 2 77 77 ENDIF 78 #endif 78 79 kpk = jpkglo 79 80 ! ! Set the lateral boundary condition of the global domain -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/USR/usrdef_sbc.F90
r12489 r13247 181 181 wndm(ji,jj) = SQRT( zmod * zcoef ) 182 182 END_2D 183 CALL lbc_lnk_multi( 'usrdef_sbc', taum(:,:), 'T', 1. , wndm(:,:), 'T', 1.)183 CALL lbc_lnk_multi( 'usrdef_sbc', taum(:,:), 'T', 1.0_wp , wndm(:,:), 'T', 1.0_wp ) 184 184 185 185 ! ---------------------------------- ! -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/ZDF/zdfddm.F90
r12377 r13247 77 77 REAL(wp) :: zaw, zbw, zrw ! local scalars 78 78 REAL(wp) :: zdt, zds 79 REAL(wp) :: zinr, zrr ! - - 80 REAL(wp) :: zavft, zavfs ! - - 79 REAL(wp) :: zinr ! - - 80 REAL(dp) :: zrr ! - - 81 REAL(wp) :: zavft ! - - 82 REAL(dp) :: zavfs ! - - 81 83 REAL(wp) :: zavdt, zavds ! - - 82 84 REAL(wp), DIMENSION(jpi,jpj) :: zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3 -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/ZDF/zdfosm.F90
r12738 r13247 1218 1218 1219 1219 ! Lateral boundary conditions on zvicos (sign unchanged), needed to caclulate viscosities on u and v grids 1220 CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1. )1220 CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1.0_wp ) 1221 1221 1222 1222 ! GN 25/8: need to change tmask --> wmask … … 1227 1227 END_3D 1228 1228 ! Lateral boundary conditions on ghamu and ghamv, currently on W-grid (sign unchanged), needed to caclulate gham[uv] on u and v grids 1229 CALL lbc_lnk_multi( 'zdfosm', p_avt, 'W', 1. , p_avm, 'W', 1., &1230 & ghamu, 'W', 1. , ghamv, 'W', 1.)1229 CALL lbc_lnk_multi( 'zdfosm', p_avt, 'W', 1.0_wp , p_avm, 'W', 1.0_wp, & 1230 & ghamu, 'W', 1.0_wp , ghamv, 'W', 1.0_wp ) 1231 1231 DO_3D_00_00( 2, jpkm1 ) 1232 1232 ghamu(ji,jj,jk) = ( ghamu(ji,jj,jk) + ghamu(ji+1,jj,jk) ) & … … 1241 1241 ! Lateral boundary conditions on final outputs for gham[ts], on W-grid (sign unchanged) 1242 1242 ! Lateral boundary conditions on final outputs for gham[uv], on [UV]-grid (sign unchanged) 1243 CALL lbc_lnk_multi( 'zdfosm', ghamt, 'W', 1. , ghams, 'W', 1., &1244 & ghamu, 'U', 1. , ghamv, 'V', 1.)1243 CALL lbc_lnk_multi( 'zdfosm', ghamt, 'W', 1.0_wp , ghams, 'W', 1.0_wp, & 1244 & ghamu, 'U', 1.0_wp , ghamv, 'V', 1.0_wp ) 1245 1245 1246 1246 IF(ln_dia_osm) THEN … … 1282 1282 END IF 1283 1283 ! Lateral boundary conditions on p_avt (sign unchanged) 1284 CALL lbc_lnk( 'zdfosm', p_avt(:,:,:), 'W', 1. )1284 CALL lbc_lnk( 'zdfosm', p_avt(:,:,:), 'W', 1.0_wp ) 1285 1285 ! 1286 1286 END SUBROUTINE zdf_osm -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/ZDF/zdfphy.F90
r12810 r13247 302 302 ! !* Lateral boundary conditions (sign unchanged) 303 303 IF( l_zdfsh2 ) THEN 304 CALL lbc_lnk_multi( 'zdfphy', avm_k, 'W', 1. , avt_k, 'W', 1., &305 & avm , 'W', 1. , avt , 'W', 1. , avs , 'W', 1.)304 CALL lbc_lnk_multi( 'zdfphy', avm_k, 'W', 1.0_wp , avt_k, 'W', 1.0_wp, & 305 & avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp ) 306 306 ELSE 307 CALL lbc_lnk_multi( 'zdfphy', avm , 'W', 1. , avt , 'W', 1. , avs , 'W', 1.)307 CALL lbc_lnk_multi( 'zdfphy', avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp ) 308 308 ENDIF 309 309 ! 310 310 IF( l_zdfdrg ) THEN ! drag have been updated (non-linear cases) 311 IF( ln_isfcav ) THEN ; CALL lbc_lnk_multi( 'zdfphy', rCdU_top, 'T', 1. , rCdU_bot, 'T', 1.) ! top & bot drag312 ELSE ; CALL lbc_lnk ( 'zdfphy', rCdU_bot, 'T', 1. ) ! bottom drag only311 IF( ln_isfcav ) THEN ; CALL lbc_lnk_multi( 'zdfphy', rCdU_top, 'T', 1.0_wp , rCdU_bot, 'T', 1.0_wp ) ! top & bot drag 312 ELSE ; CALL lbc_lnk ( 'zdfphy', rCdU_bot, 'T', 1.0_wp ) ! bottom drag only 313 313 ENDIF 314 314 ENDIF -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/ZDF/zdftke.F90
r13015 r13247 310 310 DO_3D_00_00( 2, jpkm1 ) 311 311 ! ! local Richardson number 312 zri = MAX( rn2b(ji,jj,jk), 0._wp ) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear ) 312 IF (rn2b(ji,jj,jk) <= 0.0_wp) then 313 zri = 0.0_wp 314 ELSE 315 zri = rn2b(ji,jj,jk) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear ) 316 ENDIF 313 317 ! ! inverse of Prandtl number 314 318 apdlr(ji,jj,jk) = MAX( 0.1_wp, ri_cri / MAX( ri_cri , zri ) ) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/lib_fortran.F90
r12377 r13247 143 143 !!---------------------------------------------------------------------- 144 144 REAL(wp), INTENT(in ) :: ptab(:,:) ! array on which operation is applied 145 COMPLEX( wp) :: local_sum_2d146 ! 147 !!----------------------------------------------------------------------- 148 ! 149 COMPLEX( wp):: ctmp145 COMPLEX(dp) :: local_sum_2d 146 ! 147 !!----------------------------------------------------------------------- 148 ! 149 COMPLEX(dp):: ctmp 150 150 REAL(wp) :: ztmp 151 151 INTEGER :: ji, jj ! dummy loop indices … … 161 161 DO ji = 1, ipi 162 162 ztmp = ptab(ji,jj) * tmask_i(ji,jj) 163 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )163 CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) 164 164 END DO 165 165 END DO … … 172 172 !!---------------------------------------------------------------------- 173 173 REAL(wp), INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied 174 COMPLEX( wp) :: local_sum_3d175 ! 176 !!----------------------------------------------------------------------- 177 ! 178 COMPLEX( wp):: ctmp174 COMPLEX(dp) :: local_sum_3d 175 ! 176 !!----------------------------------------------------------------------- 177 ! 178 COMPLEX(dp):: ctmp 179 179 REAL(wp) :: ztmp 180 180 INTEGER :: ji, jj, jk ! dummy loop indices … … 192 192 DO ji = 1, ipi 193 193 ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) 194 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )194 CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) 195 195 END DO 196 196 END DO … … 226 226 ENDIF 227 227 END_2D 228 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. )228 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 229 229 IF( nbondi /= -1 ) THEN 230 230 IF( MOD(mig( 1), 3) == 1 ) p2d( 1,:) = p2d( 2,:) … … 243 243 IF( MOD(mjg(jpj-2), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj) 244 244 ENDIF 245 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. )245 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 246 246 247 247 END SUBROUTINE sum3x3_2d … … 274 274 END_2D 275 275 END DO 276 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. )276 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 277 277 IF( nbondi /= -1 ) THEN 278 278 IF( MOD(mig( 1), 3) == 1 ) p3d( 1,:,:) = p3d( 2,:,:) … … 291 291 IF( MOD(mjg(jpj-2), 3) == 0 ) p3d(:,jpj-1,:) = p3d(:, jpj,:) 292 292 ENDIF 293 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. )293 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 294 294 295 295 END SUBROUTINE sum3x3_3d … … 313 313 !! Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001 314 314 !!---------------------------------------------------------------------- 315 COMPLEX( wp), INTENT(in ) :: ydda316 COMPLEX( wp), INTENT(inout) :: yddb317 ! 318 REAL( wp) :: zerr, zt1, zt2 ! local work variables315 COMPLEX(dp), INTENT(in ) :: ydda 316 COMPLEX(dp), INTENT(inout) :: yddb 317 ! 318 REAL(dp) :: zerr, zt1, zt2 ! local work variables 319 319 !!----------------------------------------------------------------------- 320 320 ! -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/lib_fortran_generic.h90
r10425 r13247 40 40 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 41 41 !! 42 COMPLEX( wp):: ctmp42 COMPLEX(dp):: ctmp 43 43 REAL(wp) :: ztmp 44 44 INTEGER :: ji, jj, jk ! dummy loop indices … … 50 50 ipk = K_SIZE(ptab) ! 3rd dimension 51 51 ! 52 ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated52 ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated 53 53 54 54 DO jk = 1, ipk … … 56 56 DO ji = 1, ipi 57 57 ztmp = ARRAY_IN(ji,jj,jk) * MASK_ARRAY(ji,jj) 58 CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp )58 CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) 59 59 END DO 60 60 END DO … … 109 109 REAL(wp) :: FUNCTION_GLOB_OP ! global sum 110 110 !! 111 COMPLEX( wp):: ctmp111 COMPLEX(dp):: ctmp 112 112 REAL(wp) :: ztmp 113 113 INTEGER :: jk ! dummy loop indices -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/nemogcm.F90
r13229 r13247 363 363 WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 364 364 WRITE(numout,*) 365 366 ! Print the working precision to ocean.output 367 IF (wp == dp) THEN 368 WRITE(numout,*) "Working precision = double-precision" 369 ELSE 370 WRITE(numout,*) "Working precision = single-precision" 371 ENDIF 372 WRITE(numout,*) 365 373 ! 366 374 WRITE(numout,cform_aaa) ! Flag AAAAAAA -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/par_kind.F90
r13229 r13247 24 24 INTEGER, PUBLIC, PARAMETER :: sp = SELECTED_REAL_KIND( 6, 37) !: single precision (real 4) 25 25 INTEGER, PUBLIC, PARAMETER :: dp = SELECTED_REAL_KIND(12,307) !: double precision (real 8) 26 # if defined key_single 27 INTEGER, PUBLIC, PARAMETER :: wp = sp !: working precision 28 # else 26 29 INTEGER, PUBLIC, PARAMETER :: wp = dp !: working precision 30 # endif 27 31 28 32 ! !!** Integer ** -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/TOP/PISCES/P2Z/p2zbio.F90
r13176 r13247 338 338 ! 339 339 IF( lk_iomput ) THEN 340 CALL lbc_lnk( 'p2zbio', zw2d(:,:,:),'T', 1. )341 CALL lbc_lnk_multi( 'p2zbio', zw3d(:,:,:,1),'T', 1. , zw3d(:,:,:,2),'T', 1., zw3d(:,:,:,3),'T', 1.)340 CALL lbc_lnk( 'p2zbio', zw2d(:,:,:),'T', 1.0_wp ) 341 CALL lbc_lnk_multi( 'p2zbio', zw3d(:,:,:,1),'T', 1.0_wp, zw3d(:,:,:,2),'T', 1.0_wp, zw3d(:,:,:,3),'T', 1.0_wp ) 342 342 ! Save diagnostics 343 343 CALL iom_put( "TNO3PHY", zw2d(:,:,1) ) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/TOP/PISCES/P2Z/p2zexp.F90
r13176 r13247 106 106 END_2D 107 107 108 CALL lbc_lnk( 'p2zexp', sedpocn, 'T', 1. )108 CALL lbc_lnk( 'p2zexp', sedpocn, 'T', 1.0_wp ) 109 109 110 110 ! Oa & Ek: diagnostics depending on jpdia2d ! left as example … … 209 209 END IF 210 210 END_2D 211 CALL lbc_lnk( 'p2zexp', cmask , 'T', 1. ) ! lateral boundary conditions on cmask (sign unchanged)211 CALL lbc_lnk( 'p2zexp', cmask , 'T', 1.0_wp ) ! lateral boundary conditions on cmask (sign unchanged) 212 212 areacot = glob_sum( 'p2zexp', e1e2t(:,:) * cmask(:,:) ) 213 213 ! -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/TOP/PISCES/P4Z/p4zbc.F90
r12738 r13247 310 310 END_3D 311 311 ! 312 CALL lbc_lnk( 'p4zbc', zcmask , 'T', 1. ) ! lateral boundary conditions on cmask (sign unchanged)312 CALL lbc_lnk( 'p4zbc', zcmask , 'T', 1.0_wp ) ! lateral boundary conditions on cmask (sign unchanged) 313 313 ! 314 314 DO_3D_11_11( 1, jpk ) -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/TOP/PISCES/P4Z/p4zopt.F90
r13176 r13247 401 401 ! 402 402 CALL trc_oce_rgb( xkrgb ) ! tabulated attenuation coefficients 403 nksrp = trc_oce_ext_lev( r_si2, 0.33e2 ) ! max level of light extinction (Blue Chl=0.01)403 nksrp = trc_oce_ext_lev( r_si2, 0.33e2_wp ) ! max level of light extinction (Blue Chl=0.01) 404 404 ! 405 405 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksrp, ' ref depth = ', gdepw_1d(nksrp+1), ' m' -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/TOP/TRP/trcsbc.F90
r13176 r13247 154 154 END SELECT 155 155 ! 156 CALL lbc_lnk( 'trcsbc', sbc_trc(:,:,:), 'T', 1. )156 CALL lbc_lnk( 'trcsbc', sbc_trc(:,:,:), 'T', 1.0_wp ) 157 157 ! Concentration dilution effect on tracers due to evaporation & precipitation 158 158 DO jn = 1, jptra -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/TOP/TRP/trcsink.F90
r12377 r13247 157 157 ! slopes 158 158 DO jk = 2, jpkm1 159 zign = 0.25 + SIGN( 0.25 , ztraz(ji,jj,jk) * ztraz(ji,jj,jk+1) )159 zign = 0.25 + SIGN( 0.25_wp, ztraz(ji,jj,jk) * ztraz(ji,jj,jk+1) ) 160 160 zakz(ji,jj,jk) = ( ztraz(ji,jj,jk) + ztraz(ji,jj,jk+1) ) * zign 161 161 END DO … … 163 163 ! Slopes limitation 164 164 DO jk = 2, jpkm1 165 zakz(ji,jj,jk) = SIGN( 1. , zakz(ji,jj,jk) ) * &165 zakz(ji,jj,jk) = SIGN( 1.0_wp, zakz(ji,jj,jk) ) * & 166 166 & MIN( ABS( zakz(ji,jj,jk) ), 2. * ABS(ztraz(ji,jj,jk+1)), 2. * ABS(ztraz(ji,jj,jk) ) ) 167 167 END DO -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/TOP/TRP/trdtrc.F90
r12377 r13247 18 18 USE trdmxl_trc ! Mixed layer trends diag. 19 19 USE iom ! I/O library 20 USE par_kind 20 21 21 22 IMPLICIT NONE … … 107 108 !!---------------------------------------------------------------------- 108 109 110 USE par_kind 111 109 112 PUBLIC trd_trc 110 113 … … 116 119 INTEGER , INTENT( in ) :: kjn ! tracer index 117 120 INTEGER , INTENT( in ) :: ktrd ! tracer trend index 118 REAL , DIMENSION(:,:,:), INTENT( inout ) :: ptrtrd ! Temperature or U trend121 REAL(wp), DIMENSION(:,:,:), INTENT( inout ) :: ptrtrd ! Temperature or U trend 119 122 WRITE(*,*) 'trd_trc : You should not have seen this print! error?', ptrtrd(1,1,1) 120 123 WRITE(*,*) ' " " : You should not have seen this print! error?', kjn -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/TOP/trcbdy.F90
r12377 r13247 96 96 END DO 97 97 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 98 CALL lbc_lnk( 'trcbdy', tr(:,:,:,:,Krhs), 'T', 1. , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 )98 CALL lbc_lnk( 'trcbdy', tr(:,:,:,:,Krhs), 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 99 99 END IF 100 100 ! -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/tests/STATION_ASF/EXPREF/launch_sasf.sh
r13229 r13247 15 15 WORK_DIR="${HOME}/tmp/STATION_ASF" 16 16 17 18 # FORC_DIR => Directory containing sea-surface + atmospheric forcings 17 # DATA_IN_DIR => Directory containing sea-surface + atmospheric forcings 19 18 # (get it there https://drive.google.com/file/d/1MxNvjhRHmMrL54y6RX7WIaM9-LGl--ZP/): 20 19 if [ `hostname` = "merlat" ]; then 21 FORC_DIR="/MEDIA/data/STATION_ASF/input_data_STATION_ASF_2016-2018"20 DATA_IN_DIR="/MEDIA/data/STATION_ASF/input_data_STATION_ASF_2016-2018" 22 21 elif [ `hostname` = "luitel" ]; then 23 FORC_DIR="/data/gcm_setup/STATION_ASF/input_data_STATION_ASF_2016-2018"22 DATA_IN_DIR="/data/gcm_setup/STATION_ASF/input_data_STATION_ASF_2016-2018" 24 23 elif [ `hostname` = "ige-meom-cal1" ]; then 25 FORC_DIR="/mnt/meom/workdir/brodeau/STATION_ASF/input_data_STATION_ASF_2016-2018"24 DATA_IN_DIR="/mnt/meom/workdir/brodeau/STATION_ASF/input_data_STATION_ASF_2016-2018" 26 25 elif [ `hostname` = "salvelinus" ]; then 27 FORC_DIR="/opt/data/STATION_ASF/input_data_STATION_ASF_2016-2018"26 DATA_IN_DIR="/opt/data/STATION_ASF/input_data_STATION_ASF_2016-2018" 28 27 else 29 echo " Boo!"; exit28 echo "Oops! We don't know `hostname` yet! Define 'DATA_IN_DIR' in the script!"; exit 30 29 fi 31 #======================32 mkdir -p ${WORK_DIR}33 30 34 31 35 32 if [ ! -f ${NEMO_EXE} ]; then echo " Mhhh, no compiled nemo.exe found into ${NEMO_DIR}/tests/STATION_ASF/BLD/bin !"; exit; fi 36 33 37 NEMO_EXPREF="${NEMO_DIR}/tests/STATION_ASF/EXPREF" 34 # NEMOGCM root directory where to fetch compiled STATION_ASF nemo.exe + setup: 35 NEMO_WRK_DIR=`pwd | sed -e "s|/tests/STATION_ASF/${expdir}||g"` 36 37 # Directory where to run the simulation: 38 PROD_DIR="${HOME}/tmp/STATION_ASF" 39 40 41 ####### End of normal user configurable section ####### 42 43 #================================================================================ 44 45 # NEMO executable to use is: 46 NEMO_EXE="${NEMO_WRK_DIR}/tests/${TC_DIR}/BLD/bin/nemo.exe" 47 48 49 echo "###########################################################" 50 echo "# S T A T I O N A i r - S e a F l u x #" 51 echo "###########################################################" 52 echo 53 echo " We shall work in here: ${STATION_ASF_DIR}/" 54 echo " NEMOGCM work depository is: ${NEMO_WRK_DIR}/" 55 echo " ==> NEMO EXE to use: ${NEMO_EXE}" 56 echo " Input forcing data into: ${DATA_IN_DIR}/" 57 echo " Production will be done into: ${PROD_DIR}/" 58 echo 59 60 mkdir -p ${PROD_DIR} 61 62 if [ ! -f ${NEMO_EXE} ]; then echo " Mhhh, no compiled 'nemo.exe' found into `dirname ${NEMO_EXE}` !"; exit; fi 63 64 echo 65 echo " *** Using the following NEMO executable:" 66 echo " ${NEMO_EXE} " 67 echo 68 69 NEMO_EXPREF="${NEMO_WRK_DIR}/tests/STATION_ASF/EXPREF" 38 70 if [ ! -d ${NEMO_EXPREF} ]; then echo " Mhhh, no EXPREF directory ${NEMO_EXPREF} !"; exit; fi 39 71 40 rsync -avP ${NEMO_EXE} ${ WORK_DIR}/72 rsync -avP ${NEMO_EXE} ${PROD_DIR}/ 41 73 42 74 for ff in "context_nemo.xml" "domain_def_nemo.xml" "field_def_nemo-oce.xml" "file_def_nemo-oce.xml" "grid_def_nemo.xml" "iodef.xml" "namelist_ref"; do 43 75 if [ ! -f ${NEMO_EXPREF}/${ff} ]; then echo " Mhhh, ${ff} not found into ${NEMO_EXPREF} !"; exit; fi 44 rsync -avPL ${NEMO_EXPREF}/${ff} ${ WORK_DIR}/76 rsync -avPL ${NEMO_EXPREF}/${ff} ${PROD_DIR}/ 45 77 done 46 78 47 79 # Copy forcing to work directory: 48 rsync -avP ${ FORC_DIR}/Station_PAPA_50N-145W*.nc ${WORK_DIR}/80 rsync -avP ${DATA_IN_DIR}/Station_PAPA_50N-145W*.nc ${PROD_DIR}/ 49 81 50 82 for CASE in "ECMWF" "COARE3p6" "NCAR" "ECMWF-noskin" "COARE3p6-noskin"; do … … 58 90 scase=`echo "${CASE}" | tr '[:upper:]' '[:lower:]'` 59 91 60 rm -f ${ WORK_DIR}/namelist_cfg61 rsync -avPL ${NEMO_EXPREF}/namelist_${scase}_cfg ${ WORK_DIR}/namelist_cfg92 rm -f ${PROD_DIR}/namelist_cfg 93 rsync -avPL ${NEMO_EXPREF}/namelist_${scase}_cfg ${PROD_DIR}/namelist_cfg 62 94 63 cd ${ WORK_DIR}/95 cd ${PROD_DIR}/ 64 96 echo 65 97 echo "Launching NEMO !"
Note: See TracChangeset
for help on using the changeset viewer.