Changeset 13226 for NEMO/trunk/src
- Timestamp:
- 2020-07-02T16:24:31+02:00 (4 years ago)
- Location:
- NEMO/trunk/src
- Files:
-
- 122 edited
- 2 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk/src/ABL/ablmod.F90
r13218 r13226 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/trunk/src/ICE/icecor.F90
r12489 r13226 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/trunk/src/ICE/icedyn.F90
r12377 r13226 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/trunk/src/ICE/icedyn_adv_pra.F90
r12489 r13226 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/trunk/src/ICE/icedyn_adv_umx.F90
r12489 r13226 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/trunk/src/ICE/icedyn_rdgrft.F90
r12489 r13226 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/trunk/src/ICE/icedyn_rhg_evp.F90
r12489 r13226 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/trunk/src/ICE/iceitd.F90
r12377 r13226 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/trunk/src/ICE/icesbc.F90
r12377 r13226 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/trunk/src/ICE/icethd.F90
r12489 r13226 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/trunk/src/ICE/icethd_dh.F90
r12489 r13226 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/trunk/src/ICE/icethd_do.F90
r12489 r13226 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/trunk/src/ICE/icethd_ent.F90
r12489 r13226 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/trunk/src/ICE/iceupdate.F90
r12489 r13226 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/trunk/src/ICE/icevar.F90
r12489 r13226 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/trunk/src/ICE/icewri.F90
r12489 r13226 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/trunk/src/NST/agrif_oce_sponge.F90
r13216 r13226 295 295 fspv(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji ,jj+1) ) * ssvmask(ji,jj) 296 296 END_2D 297 CALL lbc_lnk( 'agrif_Sponge', fspu, 'U', 1. ) ! Lateral boundary conditions298 CALL lbc_lnk( 'agrif_Sponge', fspv, 'V', 1. )297 CALL lbc_lnk( 'agrif_Sponge', fspu, 'U', 1.0_wp ) ! Lateral boundary conditions 298 CALL lbc_lnk( 'agrif_Sponge', fspv, 'V', 1.0_wp ) 299 299 300 300 spongedoneT = .TRUE. … … 311 311 & * ssvmask(ji,jj) * ssvmask(ji,jj+1) 312 312 END_2D 313 CALL lbc_lnk( 'agrif_Sponge', fspt, 'T', 1. ) ! Lateral boundary conditions314 CALL lbc_lnk( 'agrif_Sponge', fspf, 'F', 1. )313 CALL lbc_lnk( 'agrif_Sponge', fspt, 'T', 1.0_wp ) ! Lateral boundary conditions 314 CALL lbc_lnk( 'agrif_Sponge', fspf, 'F', 1.0_wp ) 315 315 316 316 spongedoneU = .TRUE. … … 334 334 END_2D 335 335 ! 336 ztabramp(:,:) = REAL( mbkt_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'T', 1. )336 ztabramp(:,:) = REAL( mbkt_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'T', 1.0_wp ) 337 337 mbkt_parent(:,:) = NINT( ztabramp(:,:) ) 338 ztabramp(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'U', 1. )338 ztabramp(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'U', 1.0_wp ) 339 339 mbku_parent(:,:) = NINT( ztabramp(:,:) ) 340 ztabramp(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'V', 1. )340 ztabramp(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'V', 1.0_wp ) 341 341 mbkv_parent(:,:) = NINT( ztabramp(:,:) ) 342 342 #endif -
NEMO/trunk/src/NST/agrif_user.F90
r13216 r13226 271 271 ENDIF 272 272 ! 273 CALL lbc_lnk( 'Agrif_Init_Domain', hu0_parent, 'U', 1. )274 CALL lbc_lnk( 'Agrif_Init_Domain', hv0_parent, 'V', 1. )275 zk(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'U', 1.)273 CALL lbc_lnk( 'Agrif_Init_Domain', hu0_parent, 'U', 1.0_wp ) 274 CALL lbc_lnk( 'Agrif_Init_Domain', hv0_parent, 'V', 1.0_wp ) 275 zk(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk('Agrif_InitValues_cont', zk, 'U', 1.0_wp ) 276 276 mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) ; 277 zk(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1. )277 zk(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1.0_wp ) 278 278 mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 279 279 -
NEMO/trunk/src/OCE/ASM/asminc.F90
r12713 r13226 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/trunk/src/OCE/BDY/bdydyn2d.F90
r11536 r13226 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/trunk/src/OCE/BDY/bdydyn3d.F90
r12377 r13226 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/trunk/src/OCE/BDY/bdyice.F90
r12489 r13226 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/trunk/src/OCE/BDY/bdyini.F90
r12921 r13226 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/trunk/src/OCE/BDY/bdylib.F90
r12489 r13226 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/trunk/src/OCE/BDY/bdytra.F90
r12377 r13226 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/trunk/src/OCE/CRS/crsdom.F90
r11536 r13226 86 86 zmask = 0.0 87 87 zmask = SUM( tmask(ijis:ijie,ij:je_2,jk) ) 88 IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0 88 IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0_wp 89 89 90 90 zmask = 0.0 91 91 zmask = SUM( vmask(ijis:ijie,je_2 ,jk) ) 92 IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0 92 IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0_wp 93 93 94 94 zmask = 0.0 95 95 zmask = SUM(umask(ijie,ij:je_2,jk)) 96 IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0 96 IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0_wp 97 97 98 98 fmask_crs(ji,je_2,jk) = fmask(ijie,2,jk) … … 108 108 zmask = 0.0 109 109 zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) 110 IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0 110 IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0_wp 111 111 112 112 zmask = 0.0 113 113 zmask = SUM( vmask(ijis:ijie,ijje ,jk) ) 114 IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0 114 IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0_wp 115 115 116 116 zmask = 0.0 117 117 zmask = SUM( umask(ijie ,ijjs:ijje,jk) ) 118 IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0 118 IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0_wp 119 119 120 120 fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk) … … 124 124 125 125 ! 126 CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 )127 CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 )128 CALL crs_lbc_lnk( umask_crs, 'U', 1.0 )129 CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 )126 CALL crs_lbc_lnk( tmask_crs, 'T', 1.0_wp ) 127 CALL crs_lbc_lnk( vmask_crs, 'V', 1.0_wp ) 128 CALL crs_lbc_lnk( umask_crs, 'U', 1.0_wp ) 129 CALL crs_lbc_lnk( fmask_crs, 'F', 1.0_wp ) 130 130 ! 131 131 END SUBROUTINE crs_dom_msk … … 206 206 207 207 ! Retroactively add back the boundary halo cells. 208 CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0 )209 CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 )208 CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0_wp ) 209 CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0_wp ) 210 210 211 211 ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd … … 296 296 ENDDO 297 297 298 CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0 , pfillval=1.0)299 CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0 , pfillval=1.0)298 CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) 299 CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) 300 300 301 301 END SUBROUTINE crs_dom_hgr … … 440 440 ENDDO 441 441 ! ! Retroactively add back the boundary halo cells. 442 CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0 )443 CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 )442 CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0_wp ) 443 CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0_wp ) 444 444 ! 445 445 ! … … 1748 1748 ENDDO 1749 1749 1750 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0 , pfillval=1.0)1751 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0 , pfillval=1.0)1750 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0_wp, pfillval=1.0_wp ) 1751 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) 1752 1752 ! 1753 1753 ! … … 1857 1857 ENDDO 1858 1858 1859 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0 , pfillval=1.0)1860 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0 , pfillval=1.0)1859 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0_wp, pfillval=1.0_wp ) 1860 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0_wp, pfillval=1.0_wp ) 1861 1861 1862 1862 END SUBROUTINE crs_dom_sfc … … 2246 2246 2247 2247 zmbk(:,:) = 0.0 2248 zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0 ) ; mbathy_crs(:,:) = NINT( zmbk(:,:) )2248 zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0_wp) ; mbathy_crs(:,:) = NINT( zmbk(:,:) ) 2249 2249 2250 2250 … … 2266 2266 ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 2267 2267 zmbk(:,:) = 1.e0; 2268 zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0 ) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 )2269 zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0 ) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 )2268 zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0_wp) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) 2269 zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0_wp) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) 2270 2270 ! 2271 2271 END SUBROUTINE crs_dom_bat -
NEMO/trunk/src/OCE/CRS/crsdomwri.F90
r12377 r13226 161 161 END DO 162 162 END DO 163 CALL crs_lbc_lnk( zdepu,'U', 1. ) ; CALL crs_lbc_lnk( zdepv,'V', 1.)163 CALL crs_lbc_lnk( zdepu,'U', 1.0_wp ) ; CALL crs_lbc_lnk( zdepv,'V', 1.0_wp ) 164 164 ! 165 165 CALL iom_rstput( 0, 0, inum, 'gdepu', zdepu, ktype = jp_r4 ) … … 222 222 ! 223 223 puniq(:,:) = ztstref(:,:) ! default definition 224 CALL crs_lbc_lnk( puniq,cdgrd, 1. ) ! apply boundary conditions224 CALL crs_lbc_lnk( puniq,cdgrd, 1.0_wp ) ! apply boundary conditions 225 225 lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed 226 226 ! -
NEMO/trunk/src/OCE/CRS/crsfld.F90
r12377 r13226 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/trunk/src/OCE/CRS/crsini.F90
r12377 r13226 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/trunk/src/OCE/DIA/diaar5.F90
r13089 r13226 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/trunk/src/OCE/DIA/diaptr.F90
r12489 r13226 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/trunk/src/OCE/DIA/diawri.F90
r13089 r13226 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/trunk/src/OCE/DOM/daymod.F90
r12489 r13226 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/trunk/src/OCE/DOM/dommsk.F90
r12965 r13226 173 173 END DO 174 174 END DO 175 CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1. , vmask, 'V', 1., fmask, 'F', 1.) ! Lateral boundary conditions175 CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1.0_wp, vmask, 'V', 1.0_wp, fmask, 'F', 1.0_wp ) ! Lateral boundary conditions 176 176 177 177 ! Ocean/land mask at wu-, wv- and w points (computed from tmask) -
NEMO/trunk/src/OCE/DOM/domwri.F90
r12377 r13226 209 209 ! 210 210 puniq(:,:) = ztstref(:,:) ! default definition 211 CALL lbc_lnk( 'domwri', puniq, cdgrd, 1. ) ! apply boundary conditions211 CALL lbc_lnk( 'domwri', puniq, cdgrd, 1.0_wp ) ! apply boundary conditions 212 212 lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed 213 213 ! … … 270 270 END DO 271 271 END DO 272 CALL lbc_lnk( 'domwri', zx1, 'T', 1. )272 CALL lbc_lnk( 'domwri', zx1, 'T', 1.0_wp ) 273 273 ! 274 274 IF( PRESENT( px1 ) ) px1 = zx1 -
NEMO/trunk/src/OCE/DOM/domzgr.F90
r12377 r13226 322 322 END_2D 323 323 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 324 zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 )325 zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 )326 zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1. ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 )327 ! 328 zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 )329 zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 )324 zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) 325 zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) 326 zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) 327 ! 328 zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) 329 zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) 330 330 ! 331 331 END SUBROUTINE zgr_top_bot -
NEMO/trunk/src/OCE/DYN/divhor.F90
r12965 r13226 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/trunk/src/OCE/DYN/dynadv_ubs.F90
r12377 r13226 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/trunk/src/OCE/DYN/dynatf.F90
r12489 r13226 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/trunk/src/OCE/DYN/dynhpg.F90
r12377 r13226 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/trunk/src/OCE/DYN/dynkeg.F90
r12377 r13226 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/trunk/src/OCE/DYN/dynldf_iso.F90
r12377 r13226 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/trunk/src/OCE/DYN/dynldf_lap_blp.F90
r12790 r13226 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/trunk/src/OCE/DYN/dynvor.F90
r12793 r13226 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/trunk/src/OCE/DYN/sshwzv.F90
r13216 r13226 115 115 IF ( .NOT.ln_dynspg_ts ) THEN 116 116 IF( ln_bdy ) THEN 117 CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1. ) ! Not sure that's necessary117 CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1.0_wp ) ! Not sure that's necessary 118 118 CALL bdy_ssh( pssh(:,:,Kaa) ) ! Duplicate sea level across open boundaries 119 119 ENDIF … … 176 176 END_2D 177 177 END DO 178 CALL lbc_lnk('sshwzv', zhdiv, 'T', 1. ) ! - ML - Perhaps not necessary: not used for horizontal "connexions"178 CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.0_wp) ! - ML - Perhaps not necessary: not used for horizontal "connexions" 179 179 ! ! Is it problematic to have a wrong vertical velocity in boundary cells? 180 180 ! ! Same question holds for hdiv. Perhaps just for security … … 364 364 END_3D 365 365 ENDIF 366 CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1. )366 CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1.0_wp ) 367 367 ! 368 368 CALL iom_put("Courant",Cu_adv) -
NEMO/trunk/src/OCE/DYN/wet_dry.F90
r12489 r13226 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/trunk/src/OCE/ICB/icblbc.F90
r12377 r13226 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/trunk/src/OCE/ICB/icbthm.F90
r12291 r13226 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/trunk/src/OCE/IOM/iom.F90
r13214 r13226 59 59 PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val 60 60 61 PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 62 PRIVATE iom_g0d, iom_g1d, iom_g2d, iom_g3d, iom_get_123d 63 PRIVATE iom_p1d, iom_p2d, iom_p3d, iom_p4d 61 PRIVATE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp 62 PRIVATE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp 63 PRIVATE iom_get_123d 64 PRIVATE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp 65 PRIVATE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp 66 PRIVATE iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp 67 PRIVATE iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp 64 68 #if defined key_iomput 65 69 PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr … … 70 74 71 75 INTERFACE iom_get 72 MODULE PROCEDURE iom_g0d, iom_g1d, iom_g2d, iom_g3d 76 MODULE PROCEDURE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp 77 MODULE PROCEDURE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp 73 78 END INTERFACE 74 79 INTERFACE iom_getatt … … 79 84 END INTERFACE 80 85 INTERFACE iom_rstput 81 MODULE PROCEDURE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 86 MODULE PROCEDURE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp 87 MODULE PROCEDURE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp 82 88 END INTERFACE 83 89 INTERFACE iom_put 84 MODULE PROCEDURE iom_p0d, iom_p1d, iom_p2d, iom_p3d, iom_p4d 90 MODULE PROCEDURE iom_p0d_sp, iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp 91 MODULE PROCEDURE iom_p0d_dp, iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp 85 92 END INTERFACE iom_put 86 93 … … 169 176 ! 170 177 IF( ln_cfmeta ) THEN ! Add additional grid metadata 171 CALL iom_set_domain_attr("grid_T", area = e1e2t(nldi:nlei, nldj:nlej))172 CALL iom_set_domain_attr("grid_U", area = e1e2u(nldi:nlei, nldj:nlej))173 CALL iom_set_domain_attr("grid_V", area = e1e2v(nldi:nlei, nldj:nlej))174 CALL iom_set_domain_attr("grid_W", area = e1e2t(nldi:nlei, nldj:nlej))178 CALL iom_set_domain_attr("grid_T", area = real( e1e2t(nldi:nlei, nldj:nlej), dp)) 179 CALL iom_set_domain_attr("grid_U", area = real( e1e2u(nldi:nlei, nldj:nlej), dp)) 180 CALL iom_set_domain_attr("grid_V", area = real( e1e2v(nldi:nlei, nldj:nlej), dp)) 181 CALL iom_set_domain_attr("grid_W", area = real( e1e2t(nldi:nlei, nldj:nlej), dp)) 175 182 CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 176 183 CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) … … 192 199 ! 193 200 IF( ln_cfmeta .AND. .NOT. llrst_context) THEN ! Add additional grid metadata 194 CALL iom_set_domain_attr("grid_T", area = e1e2t_crs(nldi:nlei, nldj:nlej))195 CALL iom_set_domain_attr("grid_U", area = e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej))196 CALL iom_set_domain_attr("grid_V", area = e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej))197 CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(nldi:nlei, nldj:nlej))201 CALL iom_set_domain_attr("grid_T", area = real(e1e2t_crs(nldi:nlei, nldj:nlej), dp)) 202 CALL iom_set_domain_attr("grid_U", area = real(e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej), dp) ) 203 CALL iom_set_domain_attr("grid_V", area = real(e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej), dp) ) 204 CALL iom_set_domain_attr("grid_W", area = real(e1e2t_crs(nldi:nlei, nldj:nlej), dp ) ) 198 205 CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 199 206 CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) … … 941 948 !! INTERFACE iom_get 942 949 !!---------------------------------------------------------------------- 943 SUBROUTINE iom_g0d ( kiomid, cdvar, pvar, ktime, ldxios )950 SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime, ldxios ) 944 951 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 945 952 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 946 REAL(wp) , INTENT( out) :: pvar ! read field 953 REAL(sp) , INTENT( out) :: pvar ! read field 954 REAL(dp) :: ztmp_pvar ! tmp var to read field 955 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 956 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart 957 ! 958 INTEGER :: idvar ! variable id 959 INTEGER :: idmspc ! number of spatial dimensions 960 INTEGER , DIMENSION(1) :: itime ! record number 961 CHARACTER(LEN=100) :: clinfo ! info character 962 CHARACTER(LEN=100) :: clname ! file name 963 CHARACTER(LEN=1) :: cldmspc ! 964 LOGICAL :: llxios 965 ! 966 llxios = .FALSE. 967 IF( PRESENT(ldxios) ) llxios = ldxios 968 969 IF(.NOT.llxios) THEN ! read data using default library 970 itime = 1 971 IF( PRESENT(ktime) ) itime = ktime 972 ! 973 clname = iom_file(kiomid)%name 974 clinfo = ' iom_g0d, file: '//trim(clname)//', var: '//trim(cdvar) 975 ! 976 IF( kiomid > 0 ) THEN 977 idvar = iom_varid( kiomid, cdvar ) 978 IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN 979 idmspc = iom_file ( kiomid )%ndims( idvar ) 980 IF( iom_file(kiomid)%luld(idvar) ) idmspc = idmspc - 1 981 WRITE(cldmspc , fmt='(i1)') idmspc 982 IF( idmspc > 0 ) CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', & 983 & 'with 1 or more spatial dimensions: '//cldmspc//' were found.' , & 984 & 'Use ncwa -a to suppress the unnecessary dimensions' ) 985 CALL iom_nf90_get( kiomid, idvar, ztmp_pvar, itime ) 986 pvar = ztmp_pvar 987 ENDIF 988 ENDIF 989 ELSE 990 #if defined key_iomput 991 IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 992 CALL iom_swap( TRIM(crxios_context) ) 993 CALL xios_recv_field( trim(cdvar), pvar) 994 CALL iom_swap( TRIM(cxios_context) ) 995 #else 996 WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) 997 CALL ctl_stop( 'iom_g0d', ctmp1 ) 998 #endif 999 ENDIF 1000 END SUBROUTINE iom_g0d_sp 1001 1002 SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime, ldxios ) 1003 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1004 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1005 REAL(dp) , INTENT( out) :: pvar ! read field 947 1006 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 948 1007 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart … … 989 1048 #endif 990 1049 ENDIF 991 END SUBROUTINE iom_g0d 992 993 SUBROUTINE iom_g1d ( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios )1050 END SUBROUTINE iom_g0d_dp 1051 1052 SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 994 1053 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 995 1054 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 996 1055 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 997 REAL(wp) , INTENT( out), DIMENSION(:) :: pvar ! read field 1056 REAL(sp) , INTENT( out), DIMENSION(:) :: pvar ! read field 1057 REAL(dp) , ALLOCATABLE , DIMENSION(:) :: ztmp_pvar ! tmp var to read field 998 1058 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 999 1059 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading … … 1002 1062 ! 1003 1063 IF( kiomid > 0 ) THEN 1064 IF( iom_file(kiomid)%nfid > 0 ) THEN 1065 ALLOCATE(ztmp_pvar(size(pvar,1))) 1066 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=ztmp_pvar, & 1067 & ktime=ktime, kstart=kstart, kcount=kcount, & 1068 & ldxios=ldxios ) 1069 pvar = ztmp_pvar 1070 DEALLOCATE(ztmp_pvar) 1071 END IF 1072 ENDIF 1073 END SUBROUTINE iom_g1d_sp 1074 1075 1076 SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 1077 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1078 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1079 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1080 REAL(dp) , INTENT( out), DIMENSION(:) :: pvar ! read field 1081 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1082 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading 1083 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis 1084 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1085 ! 1086 IF( kiomid > 0 ) THEN 1004 1087 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & 1005 1088 & ktime=ktime, kstart=kstart, kcount=kcount, & 1006 1089 & ldxios=ldxios ) 1007 1090 ENDIF 1008 END SUBROUTINE iom_g1d 1009 1010 SUBROUTINE iom_g2d ( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios)1091 END SUBROUTINE iom_g1d_dp 1092 1093 SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios) 1011 1094 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1012 1095 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1013 1096 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1014 REAL(wp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1097 REAL(sp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1098 REAL(dp) , ALLOCATABLE , DIMENSION(:,:) :: ztmp_pvar ! tmp var to read field 1015 1099 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1016 1100 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kstart ! start axis position of the reading … … 1023 1107 ! 1024 1108 IF( kiomid > 0 ) THEN 1109 IF( iom_file(kiomid)%nfid > 0 ) THEN 1110 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2))) 1111 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=ztmp_pvar, & 1112 & ktime=ktime, kstart=kstart, kcount=kcount, & 1113 & lrowattr=lrowattr, ldxios=ldxios) 1114 pvar = ztmp_pvar 1115 DEALLOCATE(ztmp_pvar) 1116 END IF 1117 ENDIF 1118 END SUBROUTINE iom_g2d_sp 1119 1120 1121 SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios) 1122 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1123 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1124 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1125 REAL(dp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field 1126 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1127 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kstart ! start axis position of the reading 1128 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kcount ! number of points in each axis 1129 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 1130 ! look for and use a file attribute 1131 ! called open_ocean_jstart to set the start 1132 ! value for the 2nd dimension (netcdf only) 1133 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1134 ! 1135 IF( kiomid > 0 ) THEN 1025 1136 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=pvar, & 1026 1137 & ktime=ktime, kstart=kstart, kcount=kcount, & 1027 1138 & lrowattr=lrowattr, ldxios=ldxios) 1028 1139 ENDIF 1029 END SUBROUTINE iom_g2d 1030 1031 SUBROUTINE iom_g3d ( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios )1140 END SUBROUTINE iom_g2d_dp 1141 1142 SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios ) 1032 1143 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1033 1144 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1034 1145 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1035 REAL(wp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1146 REAL(sp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1147 REAL(dp) , ALLOCATABLE , DIMENSION(:,:,:) :: ztmp_pvar ! tmp var to read field 1036 1148 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1037 1149 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kstart ! start axis position of the reading … … 1044 1156 ! 1045 1157 IF( kiomid > 0 ) THEN 1158 IF( iom_file(kiomid)%nfid > 0 ) THEN 1159 ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3))) 1160 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=ztmp_pvar, & 1161 & ktime=ktime, kstart=kstart, kcount=kcount, & 1162 & lrowattr=lrowattr, ldxios=ldxios ) 1163 pvar = ztmp_pvar 1164 DEALLOCATE(ztmp_pvar) 1165 END IF 1166 ENDIF 1167 END SUBROUTINE iom_g3d_sp 1168 1169 SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios ) 1170 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1171 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1172 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 1173 REAL(dp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field 1174 INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number 1175 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kstart ! start axis position of the reading 1176 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kcount ! number of points in each axis 1177 LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to 1178 ! look for and use a file attribute 1179 ! called open_ocean_jstart to set the start 1180 ! value for the 2nd dimension (netcdf only) 1181 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS 1182 ! 1183 IF( kiomid > 0 ) THEN 1046 1184 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=pvar, & 1047 1185 & ktime=ktime, kstart=kstart, kcount=kcount, & 1048 1186 & lrowattr=lrowattr, ldxios=ldxios ) 1049 1187 ENDIF 1050 END SUBROUTINE iom_g3d 1188 END SUBROUTINE iom_g3d_dp 1189 1190 1191 1051 1192 !!---------------------------------------------------------------------- 1052 1193 … … 1065 1206 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read 1066 1207 CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable 1067 REAL( wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case)1068 REAL( wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case)1069 REAL( wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case)1208 REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 1209 REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 1210 REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 1070 1211 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 1071 1212 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis … … 1096 1237 INTEGER, DIMENSION(jpmax_dims) :: idimsz ! size of the dimensions of the variable 1097 1238 INTEGER, DIMENSION(jpmax_dims) :: ishape ! size of the dimensions of the variable 1098 REAL( wp) :: zscf, zofs ! sacle_factor and add_offset1239 REAL(dp) :: zscf, zofs ! sacle_factor and add_offset 1099 1240 INTEGER :: itmp ! temporary integer 1100 1241 CHARACTER(LEN=256) :: clinfo ! info character … … 1103 1244 LOGICAL :: ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 1104 1245 INTEGER :: inlev ! number of levels for 3D data 1105 REAL( wp) :: gma, gmi1246 REAL(dp) :: gma, gmi 1106 1247 !--------------------------------------------------------------------- 1107 1248 ! … … 1312 1453 !--- overlap areas and extra hallows (mpp) 1313 1454 IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 1314 CALL lbc_lnk( 'iom', pv_r2d,'Z', -999. , kfillmode = jpfillnothing )1455 CALL lbc_lnk( 'iom', pv_r2d,'Z', -999.0_wp, kfillmode = jpfillnothing ) 1315 1456 ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN 1316 1457 ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 1317 1458 IF( icnt(3) == inlev ) THEN 1318 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999. , kfillmode = jpfillnothing )1459 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999.0_wp, kfillmode = jpfillnothing ) 1319 1460 ELSE ! put some arbitrary value (a call to lbc_lnk will be done later...) 1320 1461 DO jj = nlcj+1, jpj ; pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :) ; END DO … … 1341 1482 CALL xios_recv_field( trim(cdvar), pv_r3d) 1342 1483 IF(idom /= jpdom_unknown ) then 1343 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999. , kfillmode = jpfillnothing)1484 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999.0_wp, kfillmode = jpfillnothing) 1344 1485 ENDIF 1345 1486 ELSEIF( PRESENT(pv_r2d) ) THEN … … 1348 1489 CALL xios_recv_field( trim(cdvar), pv_r2d) 1349 1490 IF(idom /= jpdom_unknown ) THEN 1350 CALL lbc_lnk('iom', pv_r2d,'Z',-999. , kfillmode = jpfillnothing)1491 CALL lbc_lnk('iom', pv_r2d,'Z',-999.0_wp, kfillmode = jpfillnothing) 1351 1492 ENDIF 1352 1493 ELSEIF( PRESENT(pv_r1d) ) THEN … … 1363 1504 !some final adjustments 1364 1505 ! C1D case : always call lbc_lnk to replicate the central value over the whole 3X3 domain 1365 IF( lk_c1d .AND. PRESENT(pv_r2d) ) CALL lbc_lnk( 'iom', pv_r2d,'Z',1. )1366 IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1. )1506 IF( lk_c1d .AND. PRESENT(pv_r2d) ) CALL lbc_lnk( 'iom', pv_r2d,'Z',1.0_wp ) 1507 IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1.0_wp ) 1367 1508 1368 1509 !--- Apply scale_factor and offset … … 1551 1692 !! INTERFACE iom_rstput 1552 1693 !!---------------------------------------------------------------------- 1553 SUBROUTINE iom_rp0d ( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1694 SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1554 1695 INTEGER , INTENT(in) :: kt ! ocean time-step 1555 1696 INTEGER , INTENT(in) :: kwrite ! writing time-step 1556 1697 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1557 1698 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1558 REAL( wp) , INTENT(in) :: pvar ! written field1699 REAL(sp) , INTENT(in) :: pvar ! written field 1559 1700 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1560 1701 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1575 1716 IF( iom_file(kiomid)%nfid > 0 ) THEN 1576 1717 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1577 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar)1718 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = real(pvar, dp) ) 1578 1719 ENDIF 1579 1720 ENDIF 1580 1721 ENDIF 1581 END SUBROUTINE iom_rp0d 1582 1583 SUBROUTINE iom_rp 1d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1722 END SUBROUTINE iom_rp0d_sp 1723 1724 SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1584 1725 INTEGER , INTENT(in) :: kt ! ocean time-step 1585 1726 INTEGER , INTENT(in) :: kwrite ! writing time-step 1586 1727 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1587 1728 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1588 REAL(wp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1729 REAL(dp) , INTENT(in) :: pvar ! written field 1730 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1731 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1732 LOGICAL :: llx ! local xios write flag 1733 INTEGER :: ivid ! variable id 1734 1735 llx = .FALSE. 1736 IF(PRESENT(ldxios)) llx = ldxios 1737 IF( llx ) THEN 1738 #ifdef key_iomput 1739 IF( kt == kwrite ) THEN 1740 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1741 CALL xios_send_field(trim(cdvar), pvar) 1742 ENDIF 1743 #endif 1744 ELSE 1745 IF( kiomid > 0 ) THEN 1746 IF( iom_file(kiomid)%nfid > 0 ) THEN 1747 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1748 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) 1749 ENDIF 1750 ENDIF 1751 ENDIF 1752 END SUBROUTINE iom_rp0d_dp 1753 1754 1755 SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1756 INTEGER , INTENT(in) :: kt ! ocean time-step 1757 INTEGER , INTENT(in) :: kwrite ! writing time-step 1758 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1759 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1760 REAL(sp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1589 1761 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1590 1762 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1605 1777 IF( iom_file(kiomid)%nfid > 0 ) THEN 1606 1778 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1607 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar)1779 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = real(pvar, dp) ) 1608 1780 ENDIF 1609 1781 ENDIF 1610 1782 ENDIF 1611 END SUBROUTINE iom_rp1d 1612 1613 SUBROUTINE iom_rp 2d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1783 END SUBROUTINE iom_rp1d_sp 1784 1785 SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1614 1786 INTEGER , INTENT(in) :: kt ! ocean time-step 1615 1787 INTEGER , INTENT(in) :: kwrite ! writing time-step 1616 1788 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1617 1789 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1618 REAL(wp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1790 REAL(dp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1791 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1792 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1793 LOGICAL :: llx ! local xios write flag 1794 INTEGER :: ivid ! variable id 1795 1796 llx = .FALSE. 1797 IF(PRESENT(ldxios)) llx = ldxios 1798 IF( llx ) THEN 1799 #ifdef key_iomput 1800 IF( kt == kwrite ) THEN 1801 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1802 CALL xios_send_field(trim(cdvar), pvar) 1803 ENDIF 1804 #endif 1805 ELSE 1806 IF( kiomid > 0 ) THEN 1807 IF( iom_file(kiomid)%nfid > 0 ) THEN 1808 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1809 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) 1810 ENDIF 1811 ENDIF 1812 ENDIF 1813 END SUBROUTINE iom_rp1d_dp 1814 1815 1816 SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1817 INTEGER , INTENT(in) :: kt ! ocean time-step 1818 INTEGER , INTENT(in) :: kwrite ! writing time-step 1819 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1820 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1821 REAL(sp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1619 1822 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1620 1823 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1635 1838 IF( iom_file(kiomid)%nfid > 0 ) THEN 1636 1839 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1637 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar)1840 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = real(pvar, dp) ) 1638 1841 ENDIF 1639 1842 ENDIF 1640 1843 ENDIF 1641 END SUBROUTINE iom_rp2d 1642 1643 SUBROUTINE iom_rp 3d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios )1844 END SUBROUTINE iom_rp2d_sp 1845 1846 SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1644 1847 INTEGER , INTENT(in) :: kt ! ocean time-step 1645 1848 INTEGER , INTENT(in) :: kwrite ! writing time-step 1646 1849 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1647 1850 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1648 REAL(wp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1851 REAL(dp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1852 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1853 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1854 LOGICAL :: llx 1855 INTEGER :: ivid ! variable id 1856 1857 llx = .FALSE. 1858 IF(PRESENT(ldxios)) llx = ldxios 1859 IF( llx ) THEN 1860 #ifdef key_iomput 1861 IF( kt == kwrite ) THEN 1862 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1863 CALL xios_send_field(trim(cdvar), pvar) 1864 ENDIF 1865 #endif 1866 ELSE 1867 IF( kiomid > 0 ) THEN 1868 IF( iom_file(kiomid)%nfid > 0 ) THEN 1869 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1870 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) 1871 ENDIF 1872 ENDIF 1873 ENDIF 1874 END SUBROUTINE iom_rp2d_dp 1875 1876 1877 SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1878 INTEGER , INTENT(in) :: kt ! ocean time-step 1879 INTEGER , INTENT(in) :: kwrite ! writing time-step 1880 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1881 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1882 REAL(sp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1649 1883 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1650 1884 LOGICAL, OPTIONAL :: ldxios ! xios write flag … … 1665 1899 IF( iom_file(kiomid)%nfid > 0 ) THEN 1666 1900 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1901 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = real(pvar, dp) ) 1902 ENDIF 1903 ENDIF 1904 ENDIF 1905 END SUBROUTINE iom_rp3d_sp 1906 1907 SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 1908 INTEGER , INTENT(in) :: kt ! ocean time-step 1909 INTEGER , INTENT(in) :: kwrite ! writing time-step 1910 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 1911 CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name 1912 REAL(dp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1913 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1914 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1915 LOGICAL :: llx ! local xios write flag 1916 INTEGER :: ivid ! variable id 1917 1918 llx = .FALSE. 1919 IF(PRESENT(ldxios)) llx = ldxios 1920 IF( llx ) THEN 1921 #ifdef key_iomput 1922 IF( kt == kwrite ) THEN 1923 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1924 CALL xios_send_field(trim(cdvar), pvar) 1925 ENDIF 1926 #endif 1927 ELSE 1928 IF( kiomid > 0 ) THEN 1929 IF( iom_file(kiomid)%nfid > 0 ) THEN 1930 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1667 1931 CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) 1668 1932 ENDIF 1669 1933 ENDIF 1670 1934 ENDIF 1671 END SUBROUTINE iom_rp3d 1935 END SUBROUTINE iom_rp3d_dp 1936 1672 1937 1673 1938 … … 1721 1986 !! INTERFACE iom_put 1722 1987 !!---------------------------------------------------------------------- 1723 SUBROUTINE iom_p0d ( cdname, pfield0d )1988 SUBROUTINE iom_p0d_sp( cdname, pfield0d ) 1724 1989 CHARACTER(LEN=*), INTENT(in) :: cdname 1725 REAL( wp) , INTENT(in) :: pfield0d1990 REAL(sp) , INTENT(in) :: pfield0d 1726 1991 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1727 1992 #if defined key_iomput … … 1732 1997 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings 1733 1998 #endif 1734 END SUBROUTINE iom_p0d 1735 1736 SUBROUTINE iom_p1d( cdname, pfield1d ) 1999 END SUBROUTINE iom_p0d_sp 2000 2001 SUBROUTINE iom_p0d_dp( cdname, pfield0d ) 2002 CHARACTER(LEN=*), INTENT(in) :: cdname 2003 REAL(dp) , INTENT(in) :: pfield0d 2004 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 2005 #if defined key_iomput 2006 !!clem zz(:,:)=pfield0d 2007 !!clem CALL xios_send_field(cdname, zz) 2008 CALL xios_send_field(cdname, (/pfield0d/)) 2009 #else 2010 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings 2011 #endif 2012 END SUBROUTINE iom_p0d_dp 2013 2014 2015 SUBROUTINE iom_p1d_sp( cdname, pfield1d ) 1737 2016 CHARACTER(LEN=*) , INTENT(in) :: cdname 1738 REAL( wp), DIMENSION(:), INTENT(in) :: pfield1d2017 REAL(sp), DIMENSION(:), INTENT(in) :: pfield1d 1739 2018 #if defined key_iomput 1740 2019 CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) … … 1742 2021 IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings 1743 2022 #endif 1744 END SUBROUTINE iom_p1d 1745 1746 SUBROUTINE iom_p2d( cdname, pfield2d ) 2023 END SUBROUTINE iom_p1d_sp 2024 2025 SUBROUTINE iom_p1d_dp( cdname, pfield1d ) 2026 CHARACTER(LEN=*) , INTENT(in) :: cdname 2027 REAL(dp), DIMENSION(:), INTENT(in) :: pfield1d 2028 #if defined key_iomput 2029 CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) 2030 #else 2031 IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings 2032 #endif 2033 END SUBROUTINE iom_p1d_dp 2034 2035 SUBROUTINE iom_p2d_sp( cdname, pfield2d ) 1747 2036 CHARACTER(LEN=*) , INTENT(in) :: cdname 1748 REAL( wp), DIMENSION(:,:), INTENT(in) :: pfield2d2037 REAL(sp), DIMENSION(:,:), INTENT(in) :: pfield2d 1749 2038 #if defined key_iomput 1750 2039 CALL xios_send_field(cdname, pfield2d) … … 1752 2041 IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings 1753 2042 #endif 1754 END SUBROUTINE iom_p2d 1755 1756 SUBROUTINE iom_p3d( cdname, pfield3d ) 2043 END SUBROUTINE iom_p2d_sp 2044 2045 SUBROUTINE iom_p2d_dp( cdname, pfield2d ) 2046 CHARACTER(LEN=*) , INTENT(in) :: cdname 2047 REAL(dp), DIMENSION(:,:), INTENT(in) :: pfield2d 2048 #if defined key_iomput 2049 CALL xios_send_field(cdname, pfield2d) 2050 #else 2051 IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings 2052 #endif 2053 END SUBROUTINE iom_p2d_dp 2054 2055 SUBROUTINE iom_p3d_sp( cdname, pfield3d ) 1757 2056 CHARACTER(LEN=*) , INTENT(in) :: cdname 1758 REAL( wp), DIMENSION(:,:,:), INTENT(in) :: pfield3d2057 REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 1759 2058 #if defined key_iomput 1760 2059 CALL xios_send_field( cdname, pfield3d ) … … 1762 2061 IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings 1763 2062 #endif 1764 END SUBROUTINE iom_p3d 1765 1766 SUBROUTINE iom_p 4d( cdname, pfield4d )2063 END SUBROUTINE iom_p3d_sp 2064 2065 SUBROUTINE iom_p3d_dp( cdname, pfield3d ) 1767 2066 CHARACTER(LEN=*) , INTENT(in) :: cdname 1768 REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 2067 REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 2068 #if defined key_iomput 2069 CALL xios_send_field( cdname, pfield3d ) 2070 #else 2071 IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings 2072 #endif 2073 END SUBROUTINE iom_p3d_dp 2074 2075 SUBROUTINE iom_p4d_sp( cdname, pfield4d ) 2076 CHARACTER(LEN=*) , INTENT(in) :: cdname 2077 REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 1769 2078 #if defined key_iomput 1770 2079 CALL xios_send_field(cdname, pfield4d) … … 1772 2081 IF( .FALSE. ) WRITE(numout,*) cdname, pfield4d ! useless test to avoid compilation warnings 1773 2082 #endif 1774 END SUBROUTINE iom_p4d 1775 2083 END SUBROUTINE iom_p4d_sp 2084 2085 SUBROUTINE iom_p4d_dp( cdname, pfield4d ) 2086 CHARACTER(LEN=*) , INTENT(in) :: cdname 2087 REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d 2088 #if defined key_iomput 2089 CALL xios_send_field(cdname, pfield4d) 2090 #else 2091 IF( .FALSE. ) WRITE(numout,*) cdname, pfield4d ! useless test to avoid compilation warnings 2092 #endif 2093 END SUBROUTINE iom_p4d_dp 1776 2094 1777 2095 #if defined key_iomput … … 1789 2107 INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj 1790 2108 INTEGER , OPTIONAL, INTENT(in) :: nvertex 1791 REAL( wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue1792 REAL( wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area2109 REAL(dp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 2110 REAL(dp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1793 2111 LOGICAL , DIMENSION(:) , OPTIONAL, INTENT(in) :: mask 1794 2112 !!---------------------------------------------------------------------- … … 1853 2171 !!---------------------------------------------------------------------- 1854 2172 IF( PRESENT(paxis) ) THEN 1855 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=paxis ) 1856 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 1857 ENDIF 1858 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=bounds ) 1859 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 2173 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 2174 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 2175 ENDIF 2176 IF( PRESENT(bounds) ) THEN 2177 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=real(bounds, dp) ) 2178 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=real(bounds, dp) ) 2179 ELSE 2180 IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid) 2181 IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid) 2182 END IF 1860 2183 CALL xios_solve_inheritance() 1861 2184 END SUBROUTINE iom_set_axis_attr … … 1976 2299 !don't define lon and lat for restart reading context. 1977 2300 IF ( .NOT.ldrxios ) & 1978 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), &1979 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))2301 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = real(RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), dp), & 2302 & latvalue = real(RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)),dp ) ) 1980 2303 ! 1981 2304 IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN … … 1983 2306 SELECT CASE ( cdgrd ) 1984 2307 CASE('T') ; zmask(:,:,:) = tmask(:,:,:) 1985 CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( 'iom', zmask, 'U', 1. )1986 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( 'iom', zmask, 'V', 1. )2308 CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( 'iom', zmask, 'U', 1.0_wp ) 2309 CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( 'iom', zmask, 'V', 1.0_wp ) 1987 2310 CASE('W') ; zmask(:,:,2:jpk ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk) ; zmask(:,:,1) = tmask(:,:,1) 1988 2311 END SELECT … … 2027 2350 ! 2028 2351 z_fld(:,:) = 1._wp 2029 CALL lbc_lnk( 'iom', z_fld, cdgrd, -1. ) ! Working array for location of northfold2352 CALL lbc_lnk( 'iom', z_fld, cdgrd, -1.0_wp ) ! Working array for location of northfold 2030 2353 ! 2031 2354 ! Cell vertices that can be defined … … 2045 2368 ! Cell vertices on boundries 2046 2369 DO jn = 1, 4 2047 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1. , pfillval=999._wp )2048 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1. , pfillval=999._wp )2370 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1.0_wp, pfillval=999._wp ) 2371 CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1.0_wp, pfillval=999._wp ) 2049 2372 END DO 2050 2373 ! … … 2092 2415 ENDIF 2093 2416 ! 2094 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), &2095 & bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 )2417 CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat =real( RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), dp), & 2418 & bounds_lon =real( RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), dp), nvertex=4 ) 2096 2419 ! 2097 2420 DEALLOCATE( z_bnds, z_fld, z_rot ) … … 2117 2440 ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0._wp 2118 2441 ! 2119 ! CALL dom_ngb( -168.53 , 65.03, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots)2120 CALL dom_ngb( 180. , 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots)2442 ! CALL dom_ngb( -168.53_wp, 65.03_wp, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) 2443 CALL dom_ngb( 180.0_wp, 90.0_wp, ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 2121 2444 CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 2122 2445 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 2123 CALL iom_set_domain_attr("gznl", lonvalue = zlon, &2124 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))2446 CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp), & 2447 & latvalue = real(RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)),dp)) 2125 2448 CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 2126 2449 ! … … 2137 2460 !! 2138 2461 !!---------------------------------------------------------------------- 2139 REAL( wp), DIMENSION(1) :: zz = 1.2462 REAL(dp), DIMENSION(1) :: zz = 1. 2140 2463 !!---------------------------------------------------------------------- 2141 2464 ! … … 2199 2522 cl1 = clgrd(jg) 2200 2523 ! Equatorial section (attributs: jbegin, ni, name_suffix) 2201 CALL dom_ngb( 0. , 0., ix, iy, cl1 )2524 CALL dom_ngb( 0.0_wp, 0.0_wp, ix, iy, cl1 ) 2202 2525 CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni=jpiglo, nj=1 ) 2203 2526 CALL iom_get_file_attr ('Eq'//cl1, name_suffix = clsuff ) … … 2425 2748 ! 2426 2749 IF ( ll24 .AND. isec == 0 ) THEN ! 00:00 of the next day -> move to 24:00 of the current day 2427 CALL ju2ymds( pjday - 1. , iyear, imonth, iday, zsec )2750 CALL ju2ymds( pjday - 1.0_wp, iyear, imonth, iday, zsec ) 2428 2751 isec = 86400 2429 2752 ENDIF … … 2483 2806 CHARACTER(LEN=*), INTENT(in ) :: cdname 2484 2807 REAL(wp) , INTENT(out) :: pmiss_val 2808 REAL(dp) :: ztmp_pmiss_val 2485 2809 #if defined key_iomput 2486 2810 ! get missing value 2487 CALL xios_get_field_attr( cdname, default_value = pmiss_val ) 2811 CALL xios_get_field_attr( cdname, default_value = ztmp_pmiss_val ) 2812 pmiss_val = ztmp_pmiss_val 2488 2813 #else 2489 2814 IF( .FALSE. ) WRITE(numout,*) cdname, pmiss_val ! useless test to avoid compilation warnings -
NEMO/trunk/src/OCE/IOM/iom_nf90.F90
r13009 r13226 33 33 34 34 INTERFACE iom_nf90_get 35 MODULE PROCEDURE iom_nf90_g0d, iom_nf90_g123d 35 MODULE PROCEDURE iom_nf90_g0d_sp 36 MODULE PROCEDURE iom_nf90_g0d_dp, iom_nf90_g123d_dp 36 37 END INTERFACE 37 38 INTERFACE iom_nf90_rstput 38 MODULE PROCEDURE iom_nf90_rp0123d 39 MODULE PROCEDURE iom_nf90_rp0123d_dp 39 40 END INTERFACE 40 41 … … 276 277 !!---------------------------------------------------------------------- 277 278 278 SUBROUTINE iom_nf90_g0d ( kiomid, kvid, pvar, kstart )279 SUBROUTINE iom_nf90_g0d_sp( kiomid, kvid, pvar, kstart ) 279 280 !!----------------------------------------------------------------------- 280 281 !! *** ROUTINE iom_nf90_g0d *** … … 284 285 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 285 286 INTEGER , INTENT(in ) :: kvid ! variable id 286 REAL( wp), INTENT( out) :: pvar ! read field287 REAL(sp), INTENT( out) :: pvar ! read field 287 288 INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 288 289 ! … … 291 292 clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) 292 293 CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) 293 END SUBROUTINE iom_nf90_g0d 294 295 296 SUBROUTINE iom_nf90_g123d( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, & 294 END SUBROUTINE iom_nf90_g0d_sp 295 296 SUBROUTINE iom_nf90_g0d_dp( kiomid, kvid, pvar, kstart ) 297 !!----------------------------------------------------------------------- 298 !! *** ROUTINE iom_nf90_g0d *** 299 !! 300 !! ** Purpose : read a scalar with NF90 301 !!----------------------------------------------------------------------- 302 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 303 INTEGER , INTENT(in ) :: kvid ! variable id 304 REAL(dp), INTENT( out) :: pvar ! read field 305 INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 306 ! 307 CHARACTER(LEN=100) :: clinfo ! info character 308 !--------------------------------------------------------------------- 309 clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) 310 CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) 311 END SUBROUTINE iom_nf90_g0d_dp 312 313 SUBROUTINE iom_nf90_g123d_dp( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, & 297 314 & pv_r1d, pv_r2d, pv_r3d ) 298 315 !!----------------------------------------------------------------------- … … 309 326 INTEGER , DIMENSION(:) , INTENT(in ) :: kcount ! number of points to be read in each axis 310 327 INTEGER , INTENT(in ) :: kx1, kx2, ky1, ky2 ! subdomain indexes 311 REAL( wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case)312 REAL( wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case)313 REAL( wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case)328 REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) 329 REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) 330 REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) 314 331 ! 315 332 CHARACTER(LEN=100) :: clinfo ! info character … … 332 349 ENDIF 333 350 ! 334 END SUBROUTINE iom_nf90_g123d 351 END SUBROUTINE iom_nf90_g123d_dp 352 335 353 336 354 … … 506 524 END SUBROUTINE iom_nf90_putatt 507 525 508 509 SUBROUTINE iom_nf90_rp0123d( kt, kwrite, kiomid, cdvar , kvid , ktype, & 526 SUBROUTINE iom_nf90_rp0123d_dp( kt, kwrite, kiomid, cdvar , kvid , ktype, & 510 527 & pv_r0d, pv_r1d, pv_r2d, pv_r3d ) 511 528 !!-------------------------------------------------------------------- … … 520 537 INTEGER , INTENT(in) :: kvid ! variable id 521 538 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable type (default R8) 522 REAL( wp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field523 REAL( wp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field524 REAL( wp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field525 REAL( wp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field539 REAL(dp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field 540 REAL(dp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field 541 REAL(dp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field 542 REAL(dp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field 526 543 ! 527 544 INTEGER :: idims ! number of dimension … … 704 721 ENDIF 705 722 ! 706 END SUBROUTINE iom_nf90_rp0123d 723 END SUBROUTINE iom_nf90_rp0123d_dp 707 724 708 725 -
NEMO/trunk/src/OCE/ISF/isfcav.F90
r12489 r13226 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/trunk/src/OCE/ISF/isfcpl.F90
r12489 r13226 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/trunk/src/OCE/ISF/isfpar.F90
r12489 r13226 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/trunk/src/OCE/LBC/lbc_lnk_multi_generic.h90
r11536 r13226 1 #if defined DIM_2d 2 # define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j) 3 # define PTR_TYPE TYPE(PTR_2D) 4 # define PTR_ptab pt2d 5 #endif 6 #if defined DIM_3d 7 # define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j,k) 8 # define PTR_TYPE TYPE(PTR_3D) 9 # define PTR_ptab pt3d 10 #endif 11 #if defined DIM_4d 12 # define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j,k,l) 13 # define PTR_TYPE TYPE(PTR_4D) 14 # define PTR_ptab pt4d 1 #if defined SINGLE_PRECISION 2 # if defined DIM_2d 3 # define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j) 4 # define PTR_TYPE TYPE(PTR_2D_sp) 5 # define PTR_ptab pt2d 6 # endif 7 # if defined DIM_3d 8 # define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j,k) 9 # define PTR_TYPE TYPE(PTR_3D_sp) 10 # define PTR_ptab pt3d 11 # endif 12 # if defined DIM_4d 13 # define ARRAY_TYPE(i,j,k,l) REAL(sp), DIMENSION(i,j,k,l) 14 # define PTR_TYPE TYPE(PTR_4D_sp) 15 # define PTR_ptab pt4d 16 # endif 17 # define PRECISION sp 18 #else 19 # if defined DIM_2d 20 # define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j) 21 # define PTR_TYPE TYPE(PTR_2D_dp) 22 # define PTR_ptab pt2d 23 # endif 24 # if defined DIM_3d 25 # define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j,k) 26 # define PTR_TYPE TYPE(PTR_3D_dp) 27 # define PTR_ptab pt3d 28 # endif 29 # if defined DIM_4d 30 # define ARRAY_TYPE(i,j,k,l) REAL(dp), DIMENSION(i,j,k,l) 31 # define PTR_TYPE TYPE(PTR_4D_dp) 32 # define PTR_ptab pt4d 33 # endif 34 # define PRECISION dp 15 35 #endif 16 36 … … 79 99 END SUBROUTINE ROUTINE_LOAD 80 100 101 #undef PRECISION 81 102 #undef ARRAY_TYPE 82 103 #undef PTR_TYPE -
NEMO/trunk/src/OCE/LBC/lbc_nfd_ext_generic.h90
r10525 r13226 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/trunk/src/OCE/LBC/lbc_nfd_generic.h90
r10425 r13226 4 4 # define F_SIZE(ptab) kfld 5 5 # if defined DIM_2d 6 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab(f) 6 # if defined SINGLE_PRECISION 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 8 # else 9 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 10 # endif 7 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 8 12 # define K_SIZE(ptab) 1 … … 10 14 # endif 11 15 # if defined DIM_3d 12 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab(f) 16 # if defined SINGLE_PRECISION 17 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 18 # else 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 20 # endif 13 21 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 14 22 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) … … 16 24 # endif 17 25 # if defined DIM_4d 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f) 26 # if defined SINGLE_PRECISION 27 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 28 # else 29 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 30 # endif 19 31 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 20 32 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) … … 41 53 # define L_SIZE(ptab) SIZE(ptab,4) 42 54 # endif 43 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 55 # if defined SINGLE_PRECISION 56 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 57 # else 58 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 59 # endif 44 60 #endif 61 62 # if defined SINGLE_PRECISION 63 # define PRECISION sp 64 # else 65 # define PRECISION dp 66 # endif 45 67 46 68 #if defined MULTI … … 167 189 END SUBROUTINE ROUTINE_NFD 168 190 191 #undef PRECISION 169 192 #undef ARRAY_TYPE 170 193 #undef ARRAY_IN -
NEMO/trunk/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r11536 r13226 4 4 # define F_SIZE(ptab) kfld 5 5 # if defined DIM_2d 6 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab(f) 6 # if defined SINGLE_PRECISION 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 8 # else 9 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 10 # endif 7 11 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 8 12 # define K_SIZE(ptab) 1 … … 10 14 # endif 11 15 # if defined DIM_3d 12 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab(f) 16 # if defined SINGLE_PRECISION 17 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 18 # else 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 20 # endif 13 21 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 14 22 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) … … 16 24 # endif 17 25 # if defined DIM_4d 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f) 26 # if defined SINGLE_PRECISION 27 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 28 # else 29 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 30 # endif 19 31 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 20 32 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 21 33 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) 22 34 # endif 23 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab2(f) 35 # if defined SINGLE_PRECISION 36 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab2(f) 37 # else 38 # define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab2(f) 39 # endif 24 40 # define J_SIZE(ptab2) SIZE(ptab2(1)%pt4d,2) 25 41 # define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt4d(i,j,k,l) … … 46 62 # define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l) 47 63 # define J_SIZE(ptab2) SIZE(ptab2,2) 48 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 49 # define ARRAY2_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 50 #endif 51 64 # if defined SINGLE_PRECISION 65 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 66 # define ARRAY2_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 67 # else 68 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 69 # define ARRAY2_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 70 # endif 71 # endif 72 # ifdef SINGLE_PRECISION 73 # define PRECISION sp 74 # else 75 # define PRECISION dp 76 # endif 52 77 SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld ) 53 78 !!---------------------------------------------------------------------- … … 345 370 END DO ! End jf loop 346 371 END SUBROUTINE ROUTINE_NFD 372 #undef PRECISION 347 373 #undef ARRAY_TYPE 348 374 #undef ARRAY_IN -
NEMO/trunk/src/OCE/LBC/lbclnk.F90
r12377 r13226 28 28 29 29 INTERFACE lbc_lnk 30 MODULE PROCEDURE mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 30 MODULE PROCEDURE mpp_lnk_2d_sp , mpp_lnk_3d_sp , mpp_lnk_4d_sp 31 MODULE PROCEDURE mpp_lnk_2d_dp , mpp_lnk_3d_dp , mpp_lnk_4d_dp 31 32 END INTERFACE 32 33 INTERFACE lbc_lnk_ptr 33 MODULE PROCEDURE mpp_lnk_2d_ptr , mpp_lnk_3d_ptr , mpp_lnk_4d_ptr 34 MODULE PROCEDURE mpp_lnk_2d_ptr_sp , mpp_lnk_3d_ptr_sp , mpp_lnk_4d_ptr_sp 35 MODULE PROCEDURE mpp_lnk_2d_ptr_dp , mpp_lnk_3d_ptr_dp , mpp_lnk_4d_ptr_dp 34 36 END INTERFACE 35 37 INTERFACE lbc_lnk_multi 36 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 38 MODULE PROCEDURE lbc_lnk_2d_multi_sp , lbc_lnk_3d_multi_sp, lbc_lnk_4d_multi_sp 39 MODULE PROCEDURE lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 37 40 END INTERFACE 38 41 ! 39 42 INTERFACE lbc_lnk_icb 40 MODULE PROCEDURE mpp_lnk_2d_icb 43 MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp 41 44 END INTERFACE 42 45 43 46 INTERFACE mpp_nfd 44 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 45 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 47 MODULE PROCEDURE mpp_nfd_2d_sp , mpp_nfd_3d_sp , mpp_nfd_4d_sp 48 MODULE PROCEDURE mpp_nfd_2d_dp , mpp_nfd_3d_dp , mpp_nfd_4d_dp 49 MODULE PROCEDURE mpp_nfd_2d_ptr_sp, mpp_nfd_3d_ptr_sp, mpp_nfd_4d_ptr_sp 50 MODULE PROCEDURE mpp_nfd_2d_ptr_dp, mpp_nfd_3d_ptr_dp, mpp_nfd_4d_ptr_dp 51 46 52 END INTERFACE 47 53 … … 92 98 !!---------------------------------------------------------------------- 93 99 94 # define DIM_2d 95 # define ROUTINE_LOAD load_ptr_2d 96 # define ROUTINE_MULTI lbc_lnk_2d_multi 97 # include "lbc_lnk_multi_generic.h90" 98 # undef ROUTINE_MULTI 99 # undef ROUTINE_LOAD 100 # undef DIM_2d 101 102 # define DIM_3d 103 # define ROUTINE_LOAD load_ptr_3d 104 # define ROUTINE_MULTI lbc_lnk_3d_multi 105 # include "lbc_lnk_multi_generic.h90" 106 # undef ROUTINE_MULTI 107 # undef ROUTINE_LOAD 108 # undef DIM_3d 109 110 # define DIM_4d 111 # define ROUTINE_LOAD load_ptr_4d 112 # define ROUTINE_MULTI lbc_lnk_4d_multi 100 !! 101 !! ---- SINGLE PRECISION VERSIONS 102 !! 103 # define SINGLE_PRECISION 104 # define DIM_2d 105 # define ROUTINE_LOAD load_ptr_2d_sp 106 # define ROUTINE_MULTI lbc_lnk_2d_multi_sp 107 # include "lbc_lnk_multi_generic.h90" 108 # undef ROUTINE_MULTI 109 # undef ROUTINE_LOAD 110 # undef DIM_2d 111 112 # define DIM_3d 113 # define ROUTINE_LOAD load_ptr_3d_sp 114 # define ROUTINE_MULTI lbc_lnk_3d_multi_sp 115 # include "lbc_lnk_multi_generic.h90" 116 # undef ROUTINE_MULTI 117 # undef ROUTINE_LOAD 118 # undef DIM_3d 119 120 # define DIM_4d 121 # define ROUTINE_LOAD load_ptr_4d_sp 122 # define ROUTINE_MULTI lbc_lnk_4d_multi_sp 123 # include "lbc_lnk_multi_generic.h90" 124 # undef ROUTINE_MULTI 125 # undef ROUTINE_LOAD 126 # undef DIM_4d 127 # undef SINGLE_PRECISION 128 !! 129 !! ---- DOUBLE PRECISION VERSIONS 130 !! 131 132 # define DIM_2d 133 # define ROUTINE_LOAD load_ptr_2d_dp 134 # define ROUTINE_MULTI lbc_lnk_2d_multi_dp 135 # include "lbc_lnk_multi_generic.h90" 136 # undef ROUTINE_MULTI 137 # undef ROUTINE_LOAD 138 # undef DIM_2d 139 140 # define DIM_3d 141 # define ROUTINE_LOAD load_ptr_3d_dp 142 # define ROUTINE_MULTI lbc_lnk_3d_multi_dp 143 # include "lbc_lnk_multi_generic.h90" 144 # undef ROUTINE_MULTI 145 # undef ROUTINE_LOAD 146 # undef DIM_3d 147 148 # define DIM_4d 149 # define ROUTINE_LOAD load_ptr_4d_dp 150 # define ROUTINE_MULTI lbc_lnk_4d_multi_dp 113 151 # include "lbc_lnk_multi_generic.h90" 114 152 # undef ROUTINE_MULTI … … 130 168 ! !== 2D array and array of 2D pointer ==! 131 169 ! 132 # define DIM_2d 133 # define ROUTINE_LNK mpp_lnk_2d 134 # include "mpp_lnk_generic.h90" 135 # undef ROUTINE_LNK 136 # define MULTI 137 # define ROUTINE_LNK mpp_lnk_2d_ptr 170 !! 171 !! ---- SINGLE PRECISION VERSIONS 172 !! 173 # define SINGLE_PRECISION 174 # define DIM_2d 175 # define ROUTINE_LNK mpp_lnk_2d_sp 176 # include "mpp_lnk_generic.h90" 177 # undef ROUTINE_LNK 178 # define MULTI 179 # define ROUTINE_LNK mpp_lnk_2d_ptr_sp 138 180 # include "mpp_lnk_generic.h90" 139 181 # undef ROUTINE_LNK … … 144 186 ! 145 187 # define DIM_3d 146 # define ROUTINE_LNK mpp_lnk_3d 147 # include "mpp_lnk_generic.h90" 148 # undef ROUTINE_LNK 149 # define MULTI 150 # define ROUTINE_LNK mpp_lnk_3d_ptr 188 # define ROUTINE_LNK mpp_lnk_3d_sp 189 # include "mpp_lnk_generic.h90" 190 # undef ROUTINE_LNK 191 # define MULTI 192 # define ROUTINE_LNK mpp_lnk_3d_ptr_sp 151 193 # include "mpp_lnk_generic.h90" 152 194 # undef ROUTINE_LNK … … 157 199 ! 158 200 # define DIM_4d 159 # define ROUTINE_LNK mpp_lnk_4d 160 # include "mpp_lnk_generic.h90" 161 # undef ROUTINE_LNK 162 # define MULTI 163 # define ROUTINE_LNK mpp_lnk_4d_ptr 164 # include "mpp_lnk_generic.h90" 165 # undef ROUTINE_LNK 166 # undef MULTI 167 # undef DIM_4d 201 # define ROUTINE_LNK mpp_lnk_4d_sp 202 # include "mpp_lnk_generic.h90" 203 # undef ROUTINE_LNK 204 # define MULTI 205 # define ROUTINE_LNK mpp_lnk_4d_ptr_sp 206 # include "mpp_lnk_generic.h90" 207 # undef ROUTINE_LNK 208 # undef MULTI 209 # undef DIM_4d 210 # undef SINGLE_PRECISION 211 212 !! 213 !! ---- DOUBLE PRECISION VERSIONS 214 !! 215 # define DIM_2d 216 # define ROUTINE_LNK mpp_lnk_2d_dp 217 # include "mpp_lnk_generic.h90" 218 # undef ROUTINE_LNK 219 # define MULTI 220 # define ROUTINE_LNK mpp_lnk_2d_ptr_dp 221 # include "mpp_lnk_generic.h90" 222 # undef ROUTINE_LNK 223 # undef MULTI 224 # undef DIM_2d 225 ! 226 ! !== 3D array and array of 3D pointer ==! 227 ! 228 # define DIM_3d 229 # define ROUTINE_LNK mpp_lnk_3d_dp 230 # include "mpp_lnk_generic.h90" 231 # undef ROUTINE_LNK 232 # define MULTI 233 # define ROUTINE_LNK mpp_lnk_3d_ptr_dp 234 # include "mpp_lnk_generic.h90" 235 # undef ROUTINE_LNK 236 # undef MULTI 237 # undef DIM_3d 238 ! 239 ! !== 4D array and array of 4D pointer ==! 240 ! 241 # define DIM_4d 242 # define ROUTINE_LNK mpp_lnk_4d_dp 243 # include "mpp_lnk_generic.h90" 244 # undef ROUTINE_LNK 245 # define MULTI 246 # define ROUTINE_LNK mpp_lnk_4d_ptr_dp 247 # include "mpp_lnk_generic.h90" 248 # undef ROUTINE_LNK 249 # undef MULTI 250 # undef DIM_4d 251 168 252 169 253 !!---------------------------------------------------------------------- … … 181 265 ! !== 2D array and array of 2D pointer ==! 182 266 ! 183 # define DIM_2d 184 # define ROUTINE_NFD mpp_nfd_2d 185 # include "mpp_nfd_generic.h90" 186 # undef ROUTINE_NFD 187 # define MULTI 188 # define ROUTINE_NFD mpp_nfd_2d_ptr 267 !! 268 !! ---- SINGLE PRECISION VERSIONS 269 !! 270 # define SINGLE_PRECISION 271 # define DIM_2d 272 # define ROUTINE_NFD mpp_nfd_2d_sp 273 # include "mpp_nfd_generic.h90" 274 # undef ROUTINE_NFD 275 # define MULTI 276 # define ROUTINE_NFD mpp_nfd_2d_ptr_sp 189 277 # include "mpp_nfd_generic.h90" 190 278 # undef ROUTINE_NFD … … 195 283 ! 196 284 # define DIM_3d 197 # define ROUTINE_NFD mpp_nfd_3d 198 # include "mpp_nfd_generic.h90" 199 # undef ROUTINE_NFD 200 # define MULTI 201 # define ROUTINE_NFD mpp_nfd_3d_ptr 285 # define ROUTINE_NFD mpp_nfd_3d_sp 286 # include "mpp_nfd_generic.h90" 287 # undef ROUTINE_NFD 288 # define MULTI 289 # define ROUTINE_NFD mpp_nfd_3d_ptr_sp 202 290 # include "mpp_nfd_generic.h90" 203 291 # undef ROUTINE_NFD … … 208 296 ! 209 297 # define DIM_4d 210 # define ROUTINE_NFD mpp_nfd_4d 211 # include "mpp_nfd_generic.h90" 212 # undef ROUTINE_NFD 213 # define MULTI 214 # define ROUTINE_NFD mpp_nfd_4d_ptr 215 # include "mpp_nfd_generic.h90" 216 # undef ROUTINE_NFD 217 # undef MULTI 218 # undef DIM_4d 219 298 # define ROUTINE_NFD mpp_nfd_4d_sp 299 # include "mpp_nfd_generic.h90" 300 # undef ROUTINE_NFD 301 # define MULTI 302 # define ROUTINE_NFD mpp_nfd_4d_ptr_sp 303 # include "mpp_nfd_generic.h90" 304 # undef ROUTINE_NFD 305 # undef MULTI 306 # undef DIM_4d 307 # undef SINGLE_PRECISION 308 309 !! 310 !! ---- DOUBLE PRECISION VERSIONS 311 !! 312 # define DIM_2d 313 # define ROUTINE_NFD mpp_nfd_2d_dp 314 # include "mpp_nfd_generic.h90" 315 # undef ROUTINE_NFD 316 # define MULTI 317 # define ROUTINE_NFD mpp_nfd_2d_ptr_dp 318 # include "mpp_nfd_generic.h90" 319 # undef ROUTINE_NFD 320 # undef MULTI 321 # undef DIM_2d 322 ! 323 ! !== 3D array and array of 3D pointer ==! 324 ! 325 # define DIM_3d 326 # define ROUTINE_NFD mpp_nfd_3d_dp 327 # include "mpp_nfd_generic.h90" 328 # undef ROUTINE_NFD 329 # define MULTI 330 # define ROUTINE_NFD mpp_nfd_3d_ptr_dp 331 # include "mpp_nfd_generic.h90" 332 # undef ROUTINE_NFD 333 # undef MULTI 334 # undef DIM_3d 335 ! 336 ! !== 4D array and array of 4D pointer ==! 337 ! 338 # define DIM_4d 339 # define ROUTINE_NFD mpp_nfd_4d_dp 340 # include "mpp_nfd_generic.h90" 341 # undef ROUTINE_NFD 342 # define MULTI 343 # define ROUTINE_NFD mpp_nfd_4d_ptr_dp 344 # include "mpp_nfd_generic.h90" 345 # undef ROUTINE_NFD 346 # undef MULTI 347 # undef DIM_4d 220 348 221 349 !!====================================================================== 222 350 223 351 224 225 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 226 !!--------------------------------------------------------------------- 352 !!====================================================================== 353 !!--------------------------------------------------------------------- 227 354 !! *** routine mpp_lbc_north_icb *** 228 355 !! … … 240 367 !! 241 368 !!---------------------------------------------------------------------- 242 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo 243 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 244 ! ! = T , U , V , F or W -points 245 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 246 !! ! north fold, = 1. otherwise 247 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold 248 ! 249 INTEGER :: ji, jj, jr 250 INTEGER :: ierr, itaille, ildi, ilei, iilb 251 INTEGER :: ipj, ij, iproc 252 ! 253 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 254 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 255 !!---------------------------------------------------------------------- 256 #if defined key_mpp_mpi 257 ! 258 ipj=4 259 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & 260 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & 261 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) ) 262 ! 263 ztab_e(:,:) = 0._wp 264 znorthloc_e(:,:) = 0._wp 265 ! 266 ij = 1 - kextj 267 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e 268 DO jj = jpj - ipj + 1 - kextj , jpj + kextj 269 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 270 ij = ij + 1 271 END DO 272 ! 273 itaille = jpimax * ( ipj + 2*kextj ) 274 ! 275 IF( ln_timing ) CALL tic_tac(.TRUE.) 276 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, & 277 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, & 278 & ncomm_north, ierr ) 279 ! 280 IF( ln_timing ) CALL tic_tac(.FALSE.) 281 ! 282 DO jr = 1, ndim_rank_north ! recover the global north array 283 iproc = nrank_north(jr) + 1 284 ildi = nldit (iproc) 285 ilei = nleit (iproc) 286 iilb = nimppt(iproc) 287 DO jj = 1-kextj, ipj+kextj 288 DO ji = ildi, ilei 289 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 290 END DO 291 END DO 292 END DO 293 294 ! 2. North-Fold boundary conditions 295 ! ---------------------------------- 296 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 297 298 ij = 1 - kextj 299 !! Scatter back to pt2d 300 DO jj = jpj - ipj + 1 - kextj , jpj + kextj 301 DO ji= 1, jpi 302 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 303 END DO 304 ij = ij +1 305 END DO 306 ! 307 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 308 ! 309 #endif 310 END SUBROUTINE mpp_lbc_north_icb 311 312 313 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 369 # define SINGLE_PRECISION 370 # define ROUTINE_LNK mpp_lbc_north_icb_sp 371 # include "mpp_lbc_north_icb_generic.h90" 372 # undef ROUTINE_LNK 373 # undef SINGLE_PRECISION 374 # define ROUTINE_LNK mpp_lbc_north_icb_dp 375 # include "mpp_lbc_north_icb_generic.h90" 376 # undef ROUTINE_LNK 377 378 314 379 !!---------------------------------------------------------------------- 315 380 !! *** routine mpp_lnk_2d_icb *** … … 333 398 !! nono : number for local neighboring processors 334 399 !!---------------------------------------------------------------------- 335 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 336 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo 337 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 338 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 339 INTEGER , INTENT(in ) :: kexti ! extra i-halo width 340 INTEGER , INTENT(in ) :: kextj ! extra j-halo width 341 ! 342 INTEGER :: jl ! dummy loop indices 343 INTEGER :: imigr, iihom, ijhom ! local integers 344 INTEGER :: ipreci, iprecj ! - - 345 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 346 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 347 !! 348 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn 349 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew 350 !!---------------------------------------------------------------------- 351 352 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area 353 iprecj = nn_hls + kextj 354 355 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 356 357 ! 1. standard boundary treatment 358 ! ------------------------------ 359 ! Order matters Here !!!! 360 ! 361 ! ! East-West boundaries 362 ! !* Cyclic east-west 363 IF( l_Iperio ) THEN 364 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east 365 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west 366 ! 367 ELSE !* closed 368 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point 369 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west 370 ENDIF 371 ! ! North-South boundaries 372 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) 373 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north 374 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south 375 ELSE !* closed 376 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point 377 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south 378 ENDIF 379 ! 380 381 ! north fold treatment 382 ! ----------------------- 383 IF( npolj /= 0 ) THEN 384 ! 385 SELECT CASE ( jpni ) 386 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 387 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 388 END SELECT 389 ! 390 ENDIF 391 392 ! 2. East and west directions exchange 393 ! ------------------------------------ 394 ! we play with the neigbours AND the row number because of the periodicity 395 ! 396 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 397 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 398 iihom = jpi-nreci-kexti 399 DO jl = 1, ipreci 400 r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 401 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 402 END DO 403 END SELECT 404 ! 405 ! ! Migrations 406 imigr = ipreci * ( jpj + 2*kextj ) 407 ! 408 IF( ln_timing ) CALL tic_tac(.TRUE.) 409 ! 410 SELECT CASE ( nbondi ) 411 CASE ( -1 ) 412 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 413 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 414 CALL mpi_wait(ml_req1,ml_stat,ml_err) 415 CASE ( 0 ) 416 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 417 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 418 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 419 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 420 CALL mpi_wait(ml_req1,ml_stat,ml_err) 421 CALL mpi_wait(ml_req2,ml_stat,ml_err) 422 CASE ( 1 ) 423 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 424 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 425 CALL mpi_wait(ml_req1,ml_stat,ml_err) 426 END SELECT 427 ! 428 IF( ln_timing ) CALL tic_tac(.FALSE.) 429 ! 430 ! ! Write Dirichlet lateral conditions 431 iihom = jpi - nn_hls 432 ! 433 SELECT CASE ( nbondi ) 434 CASE ( -1 ) 435 DO jl = 1, ipreci 436 pt2d(iihom+jl,:) = r2dew(:,jl,2) 437 END DO 438 CASE ( 0 ) 439 DO jl = 1, ipreci 440 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 441 pt2d(iihom+jl,:) = r2dew(:,jl,2) 442 END DO 443 CASE ( 1 ) 444 DO jl = 1, ipreci 445 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 446 END DO 447 END SELECT 448 449 450 ! 3. North and south directions 451 ! ----------------------------- 452 ! always closed : we play only with the neigbours 453 ! 454 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 455 ijhom = jpj-nrecj-kextj 456 DO jl = 1, iprecj 457 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 458 r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 459 END DO 460 ENDIF 461 ! 462 ! ! Migrations 463 imigr = iprecj * ( jpi + 2*kexti ) 464 ! 465 IF( ln_timing ) CALL tic_tac(.TRUE.) 466 ! 467 SELECT CASE ( nbondj ) 468 CASE ( -1 ) 469 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 470 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 471 CALL mpi_wait(ml_req1,ml_stat,ml_err) 472 CASE ( 0 ) 473 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 474 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 475 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 476 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 477 CALL mpi_wait(ml_req1,ml_stat,ml_err) 478 CALL mpi_wait(ml_req2,ml_stat,ml_err) 479 CASE ( 1 ) 480 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 481 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 482 CALL mpi_wait(ml_req1,ml_stat,ml_err) 483 END SELECT 484 ! 485 IF( ln_timing ) CALL tic_tac(.FALSE.) 486 ! 487 ! ! Write Dirichlet lateral conditions 488 ijhom = jpj - nn_hls 489 ! 490 SELECT CASE ( nbondj ) 491 CASE ( -1 ) 492 DO jl = 1, iprecj 493 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 494 END DO 495 CASE ( 0 ) 496 DO jl = 1, iprecj 497 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 498 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 499 END DO 500 CASE ( 1 ) 501 DO jl = 1, iprecj 502 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 503 END DO 504 END SELECT 505 ! 506 END SUBROUTINE mpp_lnk_2d_icb 507 400 401 # define SINGLE_PRECISION 402 # define ROUTINE_LNK mpp_lnk_2d_icb_sp 403 # include "mpp_lnk_icb_generic.h90" 404 # undef ROUTINE_LNK 405 # undef SINGLE_PRECISION 406 # define ROUTINE_LNK mpp_lnk_2d_icb_dp 407 # include "mpp_lnk_icb_generic.h90" 408 # undef ROUTINE_LNK 409 508 410 END MODULE lbclnk 509 411 -
NEMO/trunk/src/OCE/LBC/lbcnfd.F90
r11536 r13226 26 26 27 27 INTERFACE lbc_nfd 28 MODULE PROCEDURE lbc_nfd_2d , lbc_nfd_3d , lbc_nfd_4d 29 MODULE PROCEDURE lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 30 MODULE PROCEDURE lbc_nfd_2d_ext 28 MODULE PROCEDURE lbc_nfd_2d_sp , lbc_nfd_3d_sp , lbc_nfd_4d_sp 29 MODULE PROCEDURE lbc_nfd_2d_ptr_sp, lbc_nfd_3d_ptr_sp, lbc_nfd_4d_ptr_sp 30 MODULE PROCEDURE lbc_nfd_2d_ext_sp 31 MODULE PROCEDURE lbc_nfd_2d_dp , lbc_nfd_3d_dp , lbc_nfd_4d_dp 32 MODULE PROCEDURE lbc_nfd_2d_ptr_dp, lbc_nfd_3d_ptr_dp, lbc_nfd_4d_ptr_dp 33 MODULE PROCEDURE lbc_nfd_2d_ext_dp 31 34 END INTERFACE 32 35 ! 33 36 INTERFACE lbc_nfd_nogather 34 37 ! ! Currently only 4d array version is needed 35 MODULE PROCEDURE lbc_nfd_nogather_2d , lbc_nfd_nogather_3d 36 MODULE PROCEDURE lbc_nfd_nogather_4d 37 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 38 MODULE PROCEDURE lbc_nfd_nogather_2d_sp , lbc_nfd_nogather_3d_sp 39 MODULE PROCEDURE lbc_nfd_nogather_4d_sp 40 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_sp, lbc_nfd_nogather_3d_ptr_sp 41 MODULE PROCEDURE lbc_nfd_nogather_2d_dp , lbc_nfd_nogather_3d_dp 42 MODULE PROCEDURE lbc_nfd_nogather_4d_dp 43 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_dp, lbc_nfd_nogather_3d_ptr_dp 38 44 ! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr 39 45 END INTERFACE 40 46 41 TYPE, PUBLIC :: PTR_2D !: array of 2D pointers (also used in lib_mpp) 42 REAL(wp), DIMENSION (:,:) , POINTER :: pt2d 43 END TYPE PTR_2D 44 TYPE, PUBLIC :: PTR_3D !: array of 3D pointers (also used in lib_mpp) 45 REAL(wp), DIMENSION (:,:,:) , POINTER :: pt3d 46 END TYPE PTR_3D 47 TYPE, PUBLIC :: PTR_4D !: array of 4D pointers (also used in lib_mpp) 48 REAL(wp), DIMENSION (:,:,:,:), POINTER :: pt4d 49 END TYPE PTR_4D 47 TYPE, PUBLIC :: PTR_2D_dp !: array of 2D pointers (also used in lib_mpp) 48 REAL(dp), DIMENSION (:,:) , POINTER :: pt2d 49 END TYPE PTR_2D_dp 50 TYPE, PUBLIC :: PTR_3D_dp !: array of 3D pointers (also used in lib_mpp) 51 REAL(dp), DIMENSION (:,:,:) , POINTER :: pt3d 52 END TYPE PTR_3D_dp 53 TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (also used in lib_mpp) 54 REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d 55 END TYPE PTR_4D_dp 56 57 TYPE, PUBLIC :: PTR_2D_sp !: array of 2D pointers (also used in lib_mpp) 58 REAL(sp), DIMENSION (:,:) , POINTER :: pt2d 59 END TYPE PTR_2D_sp 60 TYPE, PUBLIC :: PTR_3D_sp !: array of 3D pointers (also used in lib_mpp) 61 REAL(sp), DIMENSION (:,:,:) , POINTER :: pt3d 62 END TYPE PTR_3D_sp 63 TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (also used in lib_mpp) 64 REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d 65 END TYPE PTR_4D_sp 66 50 67 51 68 PUBLIC lbc_nfd ! north fold conditions … … 75 92 !!---------------------------------------------------------------------- 76 93 ! 77 ! !== 2D array and array of 2D pointer ==! 78 ! 79 # define DIM_2d 80 # define ROUTINE_NFD lbc_nfd_2d 81 # include "lbc_nfd_generic.h90" 82 # undef ROUTINE_NFD 83 # define MULTI 84 # define ROUTINE_NFD lbc_nfd_2d_ptr 94 ! !== SINGLE PRECISION VERSIONS 95 ! 96 ! 97 ! !== 2D array and array of 2D pointer ==! 98 ! 99 # define SINGLE_PRECISION 100 # define DIM_2d 101 # define ROUTINE_NFD lbc_nfd_2d_sp 102 # include "lbc_nfd_generic.h90" 103 # undef ROUTINE_NFD 104 # define MULTI 105 # define ROUTINE_NFD lbc_nfd_2d_ptr_sp 85 106 # include "lbc_nfd_generic.h90" 86 107 # undef ROUTINE_NFD … … 91 112 ! 92 113 # define DIM_2d 93 # define ROUTINE_NFD lbc_nfd_2d_ext 114 # define ROUTINE_NFD lbc_nfd_2d_ext_sp 94 115 # include "lbc_nfd_ext_generic.h90" 95 116 # undef ROUTINE_NFD … … 99 120 ! 100 121 # define DIM_3d 101 # define ROUTINE_NFD lbc_nfd_3d 102 # include "lbc_nfd_generic.h90" 103 # undef ROUTINE_NFD 104 # define MULTI 105 # define ROUTINE_NFD lbc_nfd_3d_ptr 106 # include "lbc_nfd_generic.h90" 107 # undef ROUTINE_NFD 108 # undef MULTI 109 # undef DIM_3d 110 ! 111 ! !== 4D array and array of 4D pointer ==! 112 ! 113 # define DIM_4d 114 # define ROUTINE_NFD lbc_nfd_4d 115 # include "lbc_nfd_generic.h90" 116 # undef ROUTINE_NFD 117 # define MULTI 118 # define ROUTINE_NFD lbc_nfd_4d_ptr 122 # define ROUTINE_NFD lbc_nfd_3d_sp 123 # include "lbc_nfd_generic.h90" 124 # undef ROUTINE_NFD 125 # define MULTI 126 # define ROUTINE_NFD lbc_nfd_3d_ptr_sp 127 # include "lbc_nfd_generic.h90" 128 # undef ROUTINE_NFD 129 # undef MULTI 130 # undef DIM_3d 131 ! 132 ! !== 4D array and array of 4D pointer ==! 133 ! 134 # define DIM_4d 135 # define ROUTINE_NFD lbc_nfd_4d_sp 136 # include "lbc_nfd_generic.h90" 137 # undef ROUTINE_NFD 138 # define MULTI 139 # define ROUTINE_NFD lbc_nfd_4d_ptr_sp 119 140 # include "lbc_nfd_generic.h90" 120 141 # undef ROUTINE_NFD … … 127 148 ! 128 149 # define DIM_2d 129 # define ROUTINE_NFD lbc_nfd_nogather_2d 130 # include "lbc_nfd_nogather_generic.h90" 131 # undef ROUTINE_NFD 132 # define MULTI 133 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr 134 # include "lbc_nfd_nogather_generic.h90" 135 # undef ROUTINE_NFD 136 # undef MULTI 137 # undef DIM_2d 138 ! 139 ! !== 3D array and array of 3D pointer ==! 140 ! 141 # define DIM_3d 142 # define ROUTINE_NFD lbc_nfd_nogather_3d 143 # include "lbc_nfd_nogather_generic.h90" 144 # undef ROUTINE_NFD 145 # define MULTI 146 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr 147 # include "lbc_nfd_nogather_generic.h90" 148 # undef ROUTINE_NFD 149 # undef MULTI 150 # undef DIM_3d 151 ! 152 ! !== 4D array and array of 4D pointer ==! 153 ! 154 # define DIM_4d 155 # define ROUTINE_NFD lbc_nfd_nogather_4d 150 # define ROUTINE_NFD lbc_nfd_nogather_2d_sp 151 # include "lbc_nfd_nogather_generic.h90" 152 # undef ROUTINE_NFD 153 # define MULTI 154 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_sp 155 # include "lbc_nfd_nogather_generic.h90" 156 # undef ROUTINE_NFD 157 # undef MULTI 158 # undef DIM_2d 159 ! 160 ! !== 3D array and array of 3D pointer ==! 161 ! 162 # define DIM_3d 163 # define ROUTINE_NFD lbc_nfd_nogather_3d_sp 164 # include "lbc_nfd_nogather_generic.h90" 165 # undef ROUTINE_NFD 166 # define MULTI 167 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_sp 168 # include "lbc_nfd_nogather_generic.h90" 169 # undef ROUTINE_NFD 170 # undef MULTI 171 # undef DIM_3d 172 ! 173 ! !== 4D array and array of 4D pointer ==! 174 ! 175 # define DIM_4d 176 # define ROUTINE_NFD lbc_nfd_nogather_4d_sp 156 177 # include "lbc_nfd_nogather_generic.h90" 157 178 # undef ROUTINE_NFD … … 162 183 !# undef MULTI 163 184 # undef DIM_4d 164 165 !!---------------------------------------------------------------------- 185 # undef SINGLE_PRECISION 186 187 !!---------------------------------------------------------------------- 188 ! 189 ! !== DOUBLE PRECISION VERSIONS 190 ! 191 ! 192 ! !== 2D array and array of 2D pointer ==! 193 ! 194 # define DIM_2d 195 # define ROUTINE_NFD lbc_nfd_2d_dp 196 # include "lbc_nfd_generic.h90" 197 # undef ROUTINE_NFD 198 # define MULTI 199 # define ROUTINE_NFD lbc_nfd_2d_ptr_dp 200 # include "lbc_nfd_generic.h90" 201 # undef ROUTINE_NFD 202 # undef MULTI 203 # undef DIM_2d 204 ! 205 ! !== 2D array with extra haloes ==! 206 ! 207 # define DIM_2d 208 # define ROUTINE_NFD lbc_nfd_2d_ext_dp 209 # include "lbc_nfd_ext_generic.h90" 210 # undef ROUTINE_NFD 211 # undef DIM_2d 212 ! 213 ! !== 3D array and array of 3D pointer ==! 214 ! 215 # define DIM_3d 216 # define ROUTINE_NFD lbc_nfd_3d_dp 217 # include "lbc_nfd_generic.h90" 218 # undef ROUTINE_NFD 219 # define MULTI 220 # define ROUTINE_NFD lbc_nfd_3d_ptr_dp 221 # include "lbc_nfd_generic.h90" 222 # undef ROUTINE_NFD 223 # undef MULTI 224 # undef DIM_3d 225 ! 226 ! !== 4D array and array of 4D pointer ==! 227 ! 228 # define DIM_4d 229 # define ROUTINE_NFD lbc_nfd_4d_dp 230 # include "lbc_nfd_generic.h90" 231 # undef ROUTINE_NFD 232 # define MULTI 233 # define ROUTINE_NFD lbc_nfd_4d_ptr_dp 234 # include "lbc_nfd_generic.h90" 235 # undef ROUTINE_NFD 236 # undef MULTI 237 # undef DIM_4d 238 ! 239 ! lbc_nfd_nogather routines 240 ! 241 ! !== 2D array and array of 2D pointer ==! 242 ! 243 # define DIM_2d 244 # define ROUTINE_NFD lbc_nfd_nogather_2d_dp 245 # include "lbc_nfd_nogather_generic.h90" 246 # undef ROUTINE_NFD 247 # define MULTI 248 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_dp 249 # include "lbc_nfd_nogather_generic.h90" 250 # undef ROUTINE_NFD 251 # undef MULTI 252 # undef DIM_2d 253 ! 254 ! !== 3D array and array of 3D pointer ==! 255 ! 256 # define DIM_3d 257 # define ROUTINE_NFD lbc_nfd_nogather_3d_dp 258 # include "lbc_nfd_nogather_generic.h90" 259 # undef ROUTINE_NFD 260 # define MULTI 261 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_dp 262 # include "lbc_nfd_nogather_generic.h90" 263 # undef ROUTINE_NFD 264 # undef MULTI 265 # undef DIM_3d 266 ! 267 ! !== 4D array and array of 4D pointer ==! 268 ! 269 # define DIM_4d 270 # define ROUTINE_NFD lbc_nfd_nogather_4d_dp 271 # include "lbc_nfd_nogather_generic.h90" 272 # undef ROUTINE_NFD 273 !# define MULTI 274 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr 275 !# include "lbc_nfd_nogather_generic.h90" 276 !# undef ROUTINE_NFD 277 !# undef MULTI 278 # undef DIM_4d 279 280 !!---------------------------------------------------------------------- 281 166 282 167 283 -
NEMO/trunk/src/OCE/LBC/lib_mpp.F90
r13216 r13226 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/trunk/src/OCE/LBC/mpp_allreduce_generic.h90
r10425 r13226 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/trunk/src/OCE/LBC/mpp_lnk_generic.h90
r11536 r13226 5 5 # define OPT_K(k) ,ipf 6 6 # if defined DIM_2d 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f) 7 # if defined SINGLE_PRECISION 8 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) 9 # else 10 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) 11 # endif 8 12 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 9 13 # define K_SIZE(ptab) 1 … … 11 15 # endif 12 16 # if defined DIM_3d 13 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f) 17 # if defined SINGLE_PRECISION 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) 19 # else 20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) 21 # endif 14 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 15 23 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) … … 17 25 # endif 18 26 # if defined DIM_4d 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f) 27 # if defined SINGLE_PRECISION 28 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) 29 # else 30 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) 31 # endif 20 32 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 21 33 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) … … 23 35 # endif 24 36 #else 25 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 37 # if defined SINGLE_PRECISION 38 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 39 # else 40 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 41 # endif 26 42 # define NAT_IN(k) cd_nat 27 43 # define SGN_IN(k) psgn … … 44 60 # endif 45 61 #endif 62 63 # if defined SINGLE_PRECISION 64 # define PRECISION sp 65 # define SENDROUTINE mppsend_sp 66 # define RECVROUTINE mpprecv_sp 67 # else 68 # define PRECISION dp 69 # define SENDROUTINE mppsend_dp 70 # define RECVROUTINE mpprecv_dp 71 # endif 46 72 47 73 #if defined MULTI … … 67 93 INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no 68 94 INTEGER :: ihl ! number of ranks and rows to be communicated 69 REAL( wp) :: zland95 REAL(PRECISION) :: zland 70 96 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend 71 REAL( wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos72 REAL( wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos97 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos 98 REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos 73 99 LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send 74 100 LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive … … 174 200 ! 175 201 ! non-blocking send of the western/eastern side using local temporary arrays 176 IF( llsend_we ) CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we )177 IF( llsend_ea ) CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea )202 IF( llsend_we ) CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 203 IF( llsend_ea ) CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 178 204 ! blocking receive of the western/eastern halo in local temporary arrays 179 IF( llrecv_we ) CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe )180 IF( llrecv_ea ) CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea )205 IF( llrecv_we ) CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 206 IF( llrecv_ea ) CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 181 207 ! 182 208 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 289 315 ! 290 316 ! non-blocking send of the southern/northern side 291 IF( llsend_so ) CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so )292 IF( llsend_no ) CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no )317 IF( llsend_so ) CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 318 IF( llsend_no ) CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 293 319 ! blocking receive of the southern/northern halo 294 IF( llrecv_so ) CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso )295 IF( llrecv_no ) CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono )320 IF( llrecv_so ) CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso ) 321 IF( llrecv_no ) CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono ) 296 322 ! 297 323 IF( ln_timing ) CALL tic_tac(.FALSE.) -
NEMO/trunk/src/OCE/LBC/mpp_loc_generic.h90
r12933 r13226 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 111 #undef MAX_TYPE -
NEMO/trunk/src/OCE/LBC/mpp_nfd_generic.h90
r11536 r13226 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, kfld ) … … 66 94 INTEGER, DIMENSION(:,:), ALLOCATABLE :: jj_s ! position of sent lines 67 95 INTEGER, DIMENSION(:), ALLOCATABLE :: ipj_s ! number of sent lines 68 REAL( wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl69 REAL( wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabr70 REAL( wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk71 REAL( wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio96 REAL(PRECISION), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl 97 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabr 98 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 99 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio 72 100 !!---------------------------------------------------------------------- 73 101 ! … … 160 188 DO jr = 1, nsndto 161 189 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 162 CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )190 CALL SENDROUTINE( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 163 191 ENDIF 164 192 END DO … … 176 204 ENDIF 177 205 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 178 CALL mpprecv(5, zfoldwk, ibuffsize, iproc)206 CALL RECVROUTINE(5, zfoldwk, ibuffsize, iproc) 179 207 js = 0 180 208 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) … … 246 274 ! start waiting time measurement 247 275 IF( ln_timing ) CALL tic_tac(.TRUE.) 248 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_ DOUBLE_PRECISION, &249 & znorthgloio, ibuffsize, MPI_ DOUBLE_PRECISION, ncomm_north, ierr )276 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_TYPE, & 277 & znorthgloio, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 250 278 ! 251 279 ! stop waiting time measurement … … 298 326 END SUBROUTINE ROUTINE_NFD 299 327 328 #undef PRECISION 329 #undef MPI_TYPE 330 #undef SENDROUTINE 331 #undef RECVROUTINE 300 332 #undef ARRAY_TYPE 301 333 #undef NAT_IN -
NEMO/trunk/src/OCE/LDF/ldfc1d_c2d.F90
r12377 r13226 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/trunk/src/OCE/LDF/ldfdyn.F90
r12489 r13226 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/trunk/src/OCE/LDF/ldfslp.F90
r12377 r13226 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/trunk/src/OCE/LDF/ldftra.F90
r12489 r13226 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/trunk/src/OCE/OBS/ddatetoymdhms.h90
r10068 r13226 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/trunk/src/OCE/OBS/grt_cir_dis.h90
r10068 r13226 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/trunk/src/OCE/OBS/obs_read_prof.F90
r10068 r13226 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/trunk/src/OCE/OBS/obs_read_surf.F90
r10069 r13226 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/trunk/src/OCE/OBS/obsinter_z1d.h90
r10068 r13226 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/trunk/src/OCE/SBC/fldread.F90
r12489 r13226 383 383 IF( sdjf%ln_tint ) THEN 384 384 CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fdta(2,2,1,2), sdjf%nrec_a(1) ) 385 CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,1,2),'Z',1. )385 CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,1,2),'Z',1.0_wp ) 386 386 ELSE 387 387 CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fnow(2,2,1 ), sdjf%nrec_a(1) ) 388 CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,1 ),'Z',1. )388 CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,1 ),'Z',1.0_wp ) 389 389 ENDIF 390 390 ELSE … … 397 397 IF( sdjf%ln_tint ) THEN 398 398 CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, sdjf%fdta(2,2,:,2), sdjf%nrec_a(1) ) 399 CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,:,2),'Z',1. )399 CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,:,2),'Z',1.0_wp ) 400 400 ELSE 401 401 CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, sdjf%fnow(2,2,: ), sdjf%nrec_a(1) ) 402 CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,: ),'Z',1. )402 CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,: ),'Z',1.0_wp ) 403 403 ENDIF 404 404 ELSE … … 1326 1326 !! D. Delrosso INGV 1327 1327 !!---------------------------------------------------------------------- 1328 INTEGER , INTENT(in ) :: ileni,ilenj ! lengths1329 REAL , DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points1330 REAL , DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field1331 ! 1332 REAL 1333 REAL 1334 REAL 1335 REAL 1336 LOGICAL , DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection1337 LOGICAL , DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection1328 INTEGER , INTENT(in ) :: ileni,ilenj ! lengths 1329 REAL(wp), DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points 1330 REAL(wp), DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field 1331 ! 1332 REAL(wp) , DIMENSION (ileni,ilenj) :: zmat1, zmat2, zmat3, zmat4 ! local arrays 1333 REAL(wp) , DIMENSION (ileni,ilenj) :: zmat5, zmat6, zmat7, zmat8 ! - - 1334 REAL(wp) , DIMENSION (ileni,ilenj) :: zlsm2d ! - - 1335 REAL(wp) , DIMENSION (ileni,ilenj,8) :: zlsm3d ! - - 1336 LOGICAL , DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection 1337 LOGICAL , DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection 1338 1338 !!---------------------------------------------------------------------- 1339 1339 zmat8 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(:,1)/) , DIM=2 ) -
NEMO/trunk/src/OCE/SBC/geo2ocean.F90
r12377 r13226 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/trunk/src/OCE/SBC/sbc_oce.F90
r12377 r13226 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/trunk/src/OCE/SBC/sbcblk.F90
r13214 r13226 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/trunk/src/OCE/SBC/sbccpl.F90
r13068 r13226 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/trunk/src/OCE/SBC/sbcflx.F90
r12377 r13226 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/trunk/src/OCE/SBC/sbcfwb.F90
r12489 r13226 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/trunk/src/OCE/SBC/sbcice_cice.F90
r12489 r13226 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/trunk/src/OCE/SBC/sbcmod.F90
r13216 r13226 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/trunk/src/OCE/SBC/sbcssr.F90
r12377 r13226 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/trunk/src/OCE/SBC/sbcwave.F90
r12965 r13226 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/trunk/src/OCE/STO/stopar.F90
r13216 r13226 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/trunk/src/OCE/TDE/tide_mod.F90
r12489 r13226 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/trunk/src/OCE/TRA/traadv_cen.F90
r12377 r13226 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/trunk/src/OCE/TRA/traadv_fct.F90
r12489 r13226 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 … … 220 230 END_2D 221 231 END DO 222 CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1. , zltv, 'T', 1.) ! Lateral boundary cond. (unchanged sgn)232 CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 223 233 ! 224 234 DO_3D_10_10( 1, jpkm1 ) … … 237 247 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 238 248 END_3D 239 CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1. , ztv, 'V', -1.) ! Lateral boundary cond. (unchanged sgn)249 CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 240 250 ! 241 251 DO_3D_00_00( 1, jpkm1 ) … … 289 299 END IF 290 300 ! 291 CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1. , zwx, 'U', -1. , zwy, 'V', -1., zwz, 'W', 1.)301 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 ) 292 302 ! 293 303 ! !== monotonicity algorithm ==! … … 374 384 INTEGER :: ji, jj, jk ! dummy loop indices 375 385 INTEGER :: ikm1 ! local integer 376 REAL( wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars377 REAL( wp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - -378 REAL( wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo379 !!---------------------------------------------------------------------- 380 ! 381 zbig = 1.e+40_ wp382 zrtrn = 1.e-15_ wp383 zbetup(:,:,:) = 0._ wp ; zbetdo(:,:,:) = 0._wp386 REAL(dp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars 387 REAL(dp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - 388 REAL(dp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo 389 !!---------------------------------------------------------------------- 390 ! 391 zbig = 1.e+40_dp 392 zrtrn = 1.e-15_dp 393 zbetup(:,:,:) = 0._dp ; zbetdo(:,:,:) = 0._dp 384 394 385 395 ! Search local extrema … … 423 433 END_2D 424 434 END DO 425 CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1. , zbetdo, 'T', 1.) ! lateral boundary cond. (unchanged sign)435 CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign) 426 436 427 437 ! 3. monotonic flux in the i & j direction (paa & pbb) … … 430 440 zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 431 441 zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 432 zcu = ( 0.5 + SIGN( 0.5 , paa(ji,jj,jk) ) )442 zcu = ( 0.5 + SIGN( 0.5_wp , paa(ji,jj,jk) ) ) 433 443 paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) 434 444 435 445 zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) 436 446 zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) 437 zcv = ( 0.5 + SIGN( 0.5 , pbb(ji,jj,jk) ) )447 zcv = ( 0.5 + SIGN( 0.5_wp , pbb(ji,jj,jk) ) ) 438 448 pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 439 449 … … 442 452 za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) 443 453 zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 444 zc = ( 0.5 + SIGN( 0.5 , pcc(ji,jj,jk+1) ) )454 zc = ( 0.5 + SIGN( 0.5_wp , pcc(ji,jj,jk+1) ) ) 445 455 pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 446 456 END_3D 447 CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1. , pbb, 'V', -1.) ! lateral boundary condition (changed sign)457 CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1.0_wp , pbb, 'V', -1.0_wp ) ! lateral boundary condition (changed sign) 448 458 ! 449 459 END SUBROUTINE nonosc -
NEMO/trunk/src/OCE/TRA/traadv_mus.F90
r12377 r13226 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/trunk/src/OCE/TRA/traadv_qck.F90
r12377 r13226 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/trunk/src/OCE/TRA/traadv_ubs.F90
r12377 r13226 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/trunk/src/OCE/TRA/traatf.F90
r12489 r13226 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/trunk/src/OCE/TRA/trabbc.F90
r12489 r13226 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/trunk/src/OCE/TRA/trabbl.F90
r12377 r13226 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/trunk/src/OCE/TRA/traldf_lap_blp.F90
r12377 r13226 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/trunk/src/OCE/TRA/tramle.F90
r12489 r13226 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/trunk/src/OCE/TRA/tranpc.F90
r12489 r13226 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/trunk/src/OCE/TRA/trazdf.F90
r12489 r13226 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/trunk/src/OCE/TRA/zpshde.F90
r12377 r13226 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/trunk/src/OCE/TRD/trddyn.F90
r12489 r13226 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/trunk/src/OCE/TRD/trdken.F90
r12489 r13226 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/trunk/src/OCE/TRD/trdmxl.F90
r12377 r13226 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/trunk/src/OCE/TRD/trdtrc.F90
r12377 r13226 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/trunk/src/OCE/TRD/trdvor.F90
r12489 r13226 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/trunk/src/OCE/USR/usrdef_sbc.F90
r12489 r13226 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/trunk/src/OCE/USR/usrdef_zgr.F90
r12740 r13226 200 200 z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom 201 201 ! 202 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (here jperio=0 ==>> closed)202 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1.0_wp ) ! set surrounding land to zero (here jperio=0 ==>> closed) 203 203 ! 204 204 k_bot(:,:) = NINT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere -
NEMO/trunk/src/OCE/ZDF/zdfddm.F90
r12377 r13226 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/trunk/src/OCE/ZDF/zdfosm.F90
r12489 r13226 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/trunk/src/OCE/ZDF/zdfphy.F90
r12377 r13226 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/trunk/src/OCE/ZDF/zdftke.F90
r13012 r13226 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/trunk/src/OCE/lib_fortran.F90
r12377 r13226 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/trunk/src/OCE/lib_fortran_generic.h90
r10425 r13226 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/trunk/src/OCE/nemogcm.F90
r13216 r13226 362 362 WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 363 363 WRITE(numout,*) 364 365 ! Print the working precision to ocean.output 366 IF (wp == dp) THEN 367 WRITE(numout,*) "Working precision = double-precision" 368 ELSE 369 WRITE(numout,*) "Working precision = single-precision" 370 ENDIF 371 WRITE(numout,*) 364 372 ! 365 373 WRITE(numout,cform_aaa) ! Flag AAAAAAA -
NEMO/trunk/src/OCE/par_kind.F90
r13216 r13226 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/trunk/src/TOP/PISCES/P2Z/p2zbio.F90
r12377 r13226 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/trunk/src/TOP/PISCES/P2Z/p2zexp.F90
r12489 r13226 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/trunk/src/TOP/PISCES/P4Z/p4zbc.F90
r12377 r13226 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/trunk/src/TOP/PISCES/P4Z/p4zopt.F90
r12377 r13226 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/trunk/src/TOP/TRP/trcsbc.F90
r12489 r13226 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/trunk/src/TOP/TRP/trcsink.F90
r12377 r13226 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/trunk/src/TOP/TRP/trdtrc.F90
r12377 r13226 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/trunk/src/TOP/trcbdy.F90
r12377 r13226 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 !
Note: See TracChangeset
for help on using the changeset viewer.