Changeset 7339
- Timestamp:
- 2016-11-25T16:40:32+01:00 (8 years ago)
- Location:
- branches/2016/dev_NOC_2016/NEMOGCM
- Files:
-
- 3 deleted
- 49 edited
- 23 copied
Legend:
- Unmodified
- Added
- Removed
-
branches/2016/dev_NOC_2016/NEMOGCM/ARCH/arch-macport_osx.fcm
r5656 r7339 54 54 %CPP cpp-mp-4.8 55 55 %FC mpif90 56 %FCFLAGS -fdefault-real-8 -O3 -funroll-all-loops -fcray-pointer 56 %FCFLAGS -fdefault-real-8 -O3 -funroll-all-loops -fcray-pointer -ffree-line-length-none 57 57 %FFLAGS %FCFLAGS 58 58 %LD %FC -
branches/2016/dev_NOC_2016/NEMOGCM/CONFIG/SHARED/field_def.xml
r6351 r7339 380 380 <field_group id="grid_U" grid_ref="grid_U_2D"> 381 381 <field id="e3u" long_name="U-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_U_3D" /> 382 <field id="e3u_0" long_name="Initial U-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_U_3D"/> 382 383 <field id="utau" long_name="Wind Stress along i-axis" standard_name="surface_downward_x_stress" unit="N/m2" /> 383 384 <field id="uoce" long_name="ocean current along i-axis" standard_name="sea_water_x_velocity" unit="m/s" grid_ref="grid_U_3D" /> … … 421 422 <field_group id="grid_V" grid_ref="grid_V_2D"> 422 423 <field id="e3v" long_name="V-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_V_3D" /> 424 <field id="e3v_0" long_name="Initial V-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_V_3D"/> 423 425 <field id="vtau" long_name="Wind Stress along j-axis" standard_name="surface_downward_y_stress" unit="N/m2" /> 424 426 <field id="voce" long_name="ocean current along j-axis" standard_name="sea_water_y_velocity" unit="m/s" grid_ref="grid_V_3D" /> -
branches/2016/dev_NOC_2016/NEMOGCM/CONFIG/cfg.txt
r6140 r7339 11 11 ORCA2_OFF_PISCES OPA_SRC OFF_SRC TOP_SRC 12 12 GYRE OPA_SRC 13 WAD_TEST_CASES OPA_SRC -
branches/2016/dev_NOC_2016/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r6351 r7339 145 145 CALL iom_put("e3v_0", e3t_0(:,:,:) ) 146 146 ! 147 CALL iom_put( "e3t" , fse3t_n(:,:,:) )148 CALL iom_put( "e3u" , fse3u_n(:,:,:) )149 CALL iom_put( "e3v" , fse3v_n(:,:,:) )150 CALL iom_put( "e3w" , fse3w_n(:,:,:) )147 CALL iom_put( "e3t" , e3t_n(:,:,:) ) 148 CALL iom_put( "e3u" , e3u_n(:,:,:) ) 149 CALL iom_put( "e3v" , e3v_n(:,:,:) ) 150 CALL iom_put( "e3w" , e3w_n(:,:,:) ) 151 151 IF( iom_use("e3tdef") ) & 152 CALL iom_put( "e3tdef" , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 )152 CALL iom_put( "e3tdef" , ( ( e3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 153 153 154 154 CALL iom_put( "ssh" , sshn ) ! sea surface height -
branches/2016/dev_NOC_2016/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90
r6140 r7339 105 105 IF( ln_linssh ) THEN ! Fix in time : set to the reference one for all 106 106 ! before ! now ! after ! 107 ;gdept_b = gdept_0 ; gdept_n = gdept_0 ! --- ! depth of grid-points108 ;gdepw_b = gdepw_0 ; gdepw_n = gdepw_0 ! --- !109 ; ;gde3w_n = gde3w_0 ! --- !107 gdept_b = gdept_0 ; gdept_n = gdept_0 ! --- ! depth of grid-points 108 gdepw_b = gdepw_0 ; gdepw_n = gdepw_0 ! --- ! 109 gde3w_n = gde3w_0 ! --- ! 110 110 ! 111 ;e3t_b = e3t_0 ; e3t_n = e3t_0 ; e3t_a = e3t_0 ! scale factors112 ;e3u_b = e3u_0 ; e3u_n = e3u_0 ; e3u_a = e3u_0 !113 ;e3v_b = e3v_0 ; e3v_n = e3v_0 ; e3v_a = e3v_0 !114 ; ;e3f_n = e3f_0 ! --- !115 ;e3w_b = e3w_0 ; e3w_n = e3w_0 ! --- !116 ;e3uw_b = e3uw_0 ; e3uw_n = e3uw_0 ! --- !117 ;e3vw_b = e3vw_0 ; e3vw_n = e3vw_0 ! --- !111 e3t_b = e3t_0 ; e3t_n = e3t_0 ; e3t_a = e3t_0 ! scale factors 112 e3u_b = e3u_0 ; e3u_n = e3u_0 ; e3u_a = e3u_0 ! 113 e3v_b = e3v_0 ; e3v_n = e3v_0 ; e3v_a = e3v_0 ! 114 e3f_n = e3f_0 ! --- ! 115 e3w_b = e3w_0 ; e3w_n = e3w_0 ! --- ! 116 e3uw_b = e3uw_0 ; e3uw_n = e3uw_0 ! --- ! 117 e3vw_b = e3vw_0 ; e3vw_n = e3vw_0 ! --- ! 118 118 ! 119 119 CALL wrk_alloc( jpi,jpj, z1_hu_0, z1_hv_0 ) … … 123 123 ! 124 124 ! before ! now ! after ! 125 ; ;ht_n = ht_0 ! ! water column thickness126 ;hu_b = hu_0 ; hu_n = hu_0 ; hu_a = hu_0 !127 ;hv_b = hv_0 ; hv_n = hv_0 ; hv_a = hv_0 !128 ;r1_hu_b = z1_hu_0 ; r1_hu_n = z1_hu_0 ; r1_hu_a = z1_hu_0 ! inverse of water column thickness129 ;r1_hv_b = z1_hv_0 ; r1_hv_n = z1_hv_0 ; r1_hv_a = z1_hv_0 !125 ht_n = ht_0 ! ! water column thickness 126 hu_b = hu_0 ; hu_n = hu_0 ; hu_a = hu_0 ! 127 hv_b = hv_0 ; hv_n = hv_0 ; hv_a = hv_0 ! 128 r1_hu_b = z1_hu_0 ; r1_hu_n = z1_hu_0 ; r1_hu_a = z1_hu_0 ! inverse of water column thickness 129 r1_hv_b = z1_hv_0 ; r1_hv_n = z1_hv_0 ; r1_hv_a = z1_hv_0 ! 130 130 ! 131 131 CALL wrk_dealloc( jpi,jpj, z1_hu_0, z1_hv_0 ) -
branches/2016/dev_NOC_2016/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
r6351 r7339 874 874 ! 875 875 ELSE !* Initialize at "rest" 876 e3t_b(:,:,:) = e3t_0(:,:,:) 877 e3t_n(:,:,:) = e3t_0(:,:,:) 878 sshn(:,:) = 0.0_wp 879 880 IF( ln_wd ) THEN 876 ! 877 IF( ln_wd .AND. ( cp_cfg == 'wad' ) ) THEN 878 ! 879 CALL wad_istate ! WAD test configuration : start from 880 ! uniform T-S fields and initial ssh slope 881 ! needs to be called here and in istate which is called later. 882 ! Adjust vertical metrics 883 DO jk = 1, jpk 884 e3t_n(:,:,jk) = e3t_0(:,:,jk) * ( ht_0(:,:) + sshn(:,:) ) & 885 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 886 & + e3t_0(:,:,jk) * (1._wp -tmask(:,:,jk)) 887 END DO 888 e3t_b(:,:,:) = e3t_n(:,:,:) 889 ! 890 ELSEIF( ln_wd ) THEN 891 ! 881 892 DO jj = 1, jpj 882 893 DO ji = 1, jpi 883 894 IF( e3t_0(ji,jj,1) <= 0.5_wp * rn_wdmin1 ) THEN 884 e3t_b(ji,jj,:) = 0.5_wp * rn_wdmin1 885 e3t_n(ji,jj,:) = 0.5_wp * rn_wdmin1 886 e3t_a(ji,jj,:) = 0.5_wp * rn_wdmin1 895 e3t_b(ji,jj,:) = 0.5_wp * rn_wdmin1 896 e3t_n(ji,jj,:) = 0.5_wp * rn_wdmin1 897 e3t_a(ji,jj,:) = 0.5_wp * rn_wdmin1 887 898 sshb(ji,jj) = rn_wdmin1 - bathy(ji,jj) 888 899 sshn(ji,jj) = rn_wdmin1 - bathy(ji,jj) … … 891 902 ENDDO 892 903 ENDDO 904 ! 905 ELSE 906 ! 907 e3t_b(:,:,:) = e3t_0(:,:,:) 908 e3t_n(:,:,:) = e3t_0(:,:,:) 909 sshn(:,:) = 0.0_wp 910 ! 893 911 END IF 894 912 -
branches/2016/dev_NOC_2016/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r6152 r7339 416 416 IF(lwp) WRITE(numout,*) ' Depth = rn_bathy read in namelist' 417 417 zdta(:,:) = rn_bathy 418 ! 419 IF( cp_cfg == 'wad' ) THEN 420 SELECT CASE ( jp_cfg ) 421 ! ! ==================== 422 CASE ( 1 ) ! WAD 1 configuration 423 ! ! ==================== 424 ! 425 IF(lwp) WRITE(numout,*) 426 IF(lwp) WRITE(numout,*) 'zgr_bat : Closed box with EW linear bottom slope' 427 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 428 ! 429 zdta = 1.5_wp 430 DO ji = 10, jpidta 431 zi = MIN(FLOAT(ji - 10)/FLOAT(jpidta - 10), 1.0 ) 432 zdta(ji,:) = MAX(rn_bathy*zi, 1.5) 433 IF(lwp)write(numout,*) 'ZDTA ',ji,zi,zdta(ji,1) 434 END DO 435 !!DO ji = 1, jpidta 436 !! zi = 1.0-EXP(-0.045*(ji-25.0)**2) 437 !! zdta(ji,:) = MAX(rn_bathy*zi, 1.5) 438 !! IF(lwp)write(numout,*) 'ZDTA ',ji,zi,zdta(ji,1) 439 !!END DO 440 zdta(1:2,:) = -2._wp 441 zdta(jpidta-1:jpidta,:) = -2._wp 442 zdta(:,1) = -2._wp 443 zdta(:,jpjdta) = -2._wp 444 zdta(:,1:3) = -2._wp 445 zdta(:,jpjdta-2:jpjdta) = -2._wp 446 ! ! ==================== 447 CASE ( 2, 3 ) ! WAD 2 or 3 configuration 448 ! ! ==================== 449 ! 450 IF(lwp) WRITE(numout,*) 451 IF(lwp) WRITE(numout,*) 'zgr_bat : Parobolic EW channel' 452 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 453 ! 454 DO ji = 1, jpidta 455 zi = MAX(1.0-FLOAT((ji-25)**2)/484.0, 0.0 ) 456 zi = MAX(1.0-FLOAT((ji-25)**2)/484.0, -2.0 ) 457 zdta(ji,:) = MAX(rn_bathy*zi, -20.0) 458 IF(lwp)write(numout,*) 'ZDTA ',ji,zi,zdta(ji,1) 459 END DO 460 zdta(1:2,:) = -2._wp 461 zdta(jpidta-1:jpidta,:) = -2._wp 462 zdta(:,1) = -2._wp 463 zdta(:,jpjdta) = -2._wp 464 zdta(:,1:3) = -2._wp 465 zdta(:,jpjdta-2:jpjdta) = -2._wp 466 ! ! ==================== 467 CASE ( 4 ) ! WAD 4 configuration 468 ! ! ==================== 469 ! 470 IF(lwp) WRITE(numout,*) 471 IF(lwp) WRITE(numout,*) 'zgr_bat : Parobolic bowl' 472 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 473 ! 474 DO ji = 1, jpidta 475 zi = MAX(1.0-FLOAT((ji-25)**2)/484.0, -2.0 ) 476 DO jj = 1, jpjdta 477 zj = MAX(1.0-FLOAT((jj-17)**2)/196.0, -2.0 ) 478 zdta(ji,jj) = MAX(rn_bathy*zi*zj, -2.0) 479 END DO 480 IF(lwp)write(numout,*) 'ZDTA ',ji,zi,zdta(ji,1) 481 END DO 482 zdta(1:2,:) = -2._wp 483 zdta(jpidta-1:jpidta,:) = -2._wp 484 zdta(:,1) = -2._wp 485 zdta(:,jpjdta) = -2._wp 486 zdta(:,1:3) = -2._wp 487 zdta(:,jpjdta-2:jpjdta) = -2._wp 488 ! ! =========================== 489 CASE ( 5 ) ! WAD 5 configuration 490 ! ! ==================== 491 ! 492 IF(lwp) WRITE(numout,*) 493 IF(lwp) WRITE(numout,*) 'zgr_bat : Double slope with shelf' 494 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 495 ! 496 DO ji = 1, jpidta 497 zi = MIN(FLOAT(ji)/FLOAT(jpidta - 5), 1.0 ) 498 zdta(ji,:) = MAX(rn_bathy*zi, 0.5) 499 IF(lwp)write(numout,*) 'ZDTA ',ji,zi,zdta(ji,1) 500 END DO 501 DO ji = jpidta,46,-1 502 zdta(ji,:) = 10.0 503 IF(lwp)write(numout,*) 'ZDTA ',ji,zi,zdta(ji,1) 504 END DO 505 DO ji = 46,20,-1 506 zi = 7.5/25. 507 zdta(ji,:) = MAX(10. - zi*(47.-ji),2.5) 508 IF(lwp)write(numout,*) 'ZDTA ',ji,zi,zdta(ji,1) 509 END DO 510 DO ji = 19,15,-1 511 zdta(ji,:) = 2.5 512 IF(lwp)write(numout,*) 'ZDTA ',ji,zi,zdta(ji,1) 513 END DO 514 DO ji = 15,4,-1 515 zi = 2.0/11.0 516 zdta(ji,:) = MAX(2.5 - zi*(16-ji), 0.5) 517 IF(lwp)write(numout,*) 'ZDTA ',ji,zi,zdta(ji,1) 518 END DO 519 DO ji = 4,1,-1 520 zdta(ji,:) = 0.5 521 IF(lwp)write(numout,*) 'ZDTA ',ji,zi,zdta(ji,1) 522 END DO 523 ! ! =========================== 524 zdta(1:2,:) = -4._wp 525 zdta(jpidta-1:jpidta,:) = -4._wp 526 zdta(:,1) = -4._wp 527 zdta(:,jpjdta) = -4._wp 528 zdta(:,1:3) = -4._wp 529 zdta(:,jpjdta-2:jpjdta) = -4._wp 530 ! ! =========================== 531 CASE ( 6 ) ! WAD 6 configuration 532 ! ! ==================== 533 ! 534 IF(lwp) WRITE(numout,*) 535 IF(lwp) WRITE(numout,*) 'zgr_bat : Parabolic channel with gaussian ridge' 536 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 537 ! 538 DO ji = 1, jpidta 539 zi = MAX(1.0-FLOAT((ji-25)**2)/484.0, -2.0 ) 540 zj = 0.95*MAX(EXP(-1.0*FLOAT((ji-25)**2)/32.0) , 0.0 ) 541 zdta(ji,:) = MAX(rn_bathy*(zi-zj), -2.0) 542 IF(lwp)write(numout,*) 'ZDTA ',ji,zi,zdta(ji,1) 543 END DO 544 zdta(1:2,:) = -4._wp 545 zdta(jpidta-1:jpidta,:) = -4._wp 546 zdta(:,1) = -4._wp 547 zdta(:,jpjdta) = -4._wp 548 zdta(:,1:3) = -4._wp 549 zdta(:,jpjdta-2:jpjdta) = -4._wp 550 ! ! =========================== 551 CASE DEFAULT 552 ! ! =========================== 553 WRITE(ctmp1,*) 'WAD test with a ', jp_cfg,' option is not coded' 554 ! 555 CALL ctl_stop( ctmp1 ) 556 ! 557 END SELECT 558 END IF 559 ! 418 560 IF( ln_sco ) THEN ! s-coordinate (zsc ): idta()=jpk 419 561 idta(:,:) = jpkm1 … … 2185 2327 CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 2186 2328 ! 2187 IF( .NOT.ln_wd ) THEN 2188 WHERE( e3t_0 (:,:,:) == 0._wp ) e3t_0 (:,:,:) = 1._wp 2189 WHERE( e3u_0 (:,:,:) == 0._wp ) e3u_0 (:,:,:) = 1._wp 2190 WHERE( e3v_0 (:,:,:) == 0._wp ) e3v_0 (:,:,:) = 1._wp 2191 WHERE( e3f_0 (:,:,:) == 0._wp ) e3f_0 (:,:,:) = 1._wp 2192 WHERE( e3w_0 (:,:,:) == 0._wp ) e3w_0 (:,:,:) = 1._wp 2193 WHERE( e3uw_0(:,:,:) == 0._wp ) e3uw_0(:,:,:) = 1._wp 2194 WHERE( e3vw_0(:,:,:) == 0._wp ) e3vw_0(:,:,:) = 1._wp 2195 END IF 2329 WHERE( e3t_0 (:,:,:) == 0._wp ) e3t_0 (:,:,:) = 1._wp 2330 WHERE( e3u_0 (:,:,:) == 0._wp ) e3u_0 (:,:,:) = 1._wp 2331 WHERE( e3v_0 (:,:,:) == 0._wp ) e3v_0 (:,:,:) = 1._wp 2332 WHERE( e3f_0 (:,:,:) == 0._wp ) e3f_0 (:,:,:) = 1._wp 2333 WHERE( e3w_0 (:,:,:) == 0._wp ) e3w_0 (:,:,:) = 1._wp 2334 WHERE( e3uw_0(:,:,:) == 0._wp ) e3uw_0(:,:,:) = 1._wp 2335 WHERE( e3vw_0(:,:,:) == 0._wp ) e3vw_0(:,:,:) = 1._wp 2196 2336 2197 2337 #if defined key_agrif … … 2295 2435 DO jk = 1, mbathy(ji,jj) 2296 2436 ! check coordinate is monotonically increasing 2297 IF (e3w_ n(ji,jj,jk) <= 0._wp .OR. e3t_n(ji,jj,jk) <= 0._wp ) THEN2437 IF (e3w_0(ji,jj,jk) <= 0._wp .OR. e3t_0(ji,jj,jk) <= 0._wp ) THEN 2298 2438 WRITE(ctmp1,*) 'ERROR zgr_sco : e3w or e3t =< 0 at point (i,j,k)= ', ji, jj, jk 2299 2439 WRITE(numout,*) 'ERROR zgr_sco : e3w or e3t =< 0 at point (i,j,k)= ', ji, jj, jk 2300 WRITE(numout,*) 'e3w',e3w_ n(ji,jj,:)2301 WRITE(numout,*) 'e3t',e3t_ n(ji,jj,:)2440 WRITE(numout,*) 'e3w',e3w_0(ji,jj,:) 2441 WRITE(numout,*) 'e3t',e3t_0(ji,jj,:) 2302 2442 CALL ctl_stop( ctmp1 ) 2303 2443 ENDIF 2304 2444 ! and check it has never gone negative 2305 IF( gdepw_ n(ji,jj,jk) < 0._wp .OR. gdept_n(ji,jj,jk) < 0._wp ) THEN2445 IF( gdepw_0(ji,jj,jk) < 0._wp .OR. gdept_0(ji,jj,jk) < 0._wp ) THEN 2306 2446 WRITE(ctmp1,*) 'ERROR zgr_sco : gdepw or gdept =< 0 at point (i,j,k)= ', ji, jj, jk 2307 2447 WRITE(numout,*) 'ERROR zgr_sco : gdepw or gdept =< 0 at point (i,j,k)= ', ji, jj, jk 2308 WRITE(numout,*) 'gdepw',gdepw_ n(ji,jj,:)2309 WRITE(numout,*) 'gdept',gdept_ n(ji,jj,:)2448 WRITE(numout,*) 'gdepw',gdepw_0(ji,jj,:) 2449 WRITE(numout,*) 'gdept',gdept_0(ji,jj,:) 2310 2450 CALL ctl_stop( ctmp1 ) 2311 2451 ENDIF 2312 2452 ! and check it never exceeds the total depth 2313 IF( gdepw_ n(ji,jj,jk) > hbatt(ji,jj) ) THEN2453 IF( gdepw_0(ji,jj,jk) > hbatt(ji,jj) ) THEN 2314 2454 WRITE(ctmp1,*) 'ERROR zgr_sco : gdepw > hbatt at point (i,j,k)= ', ji, jj, jk 2315 2455 WRITE(numout,*) 'ERROR zgr_sco : gdepw > hbatt at point (i,j,k)= ', ji, jj, jk 2316 WRITE(numout,*) 'gdepw',gdepw_ n(ji,jj,:)2456 WRITE(numout,*) 'gdepw',gdepw_0(ji,jj,:) 2317 2457 CALL ctl_stop( ctmp1 ) 2318 2458 ENDIF … … 2321 2461 DO jk = 1, mbathy(ji,jj)-1 2322 2462 ! and check it never exceeds the total depth 2323 IF( gdept_ n(ji,jj,jk) > hbatt(ji,jj) ) THEN2463 IF( gdept_0(ji,jj,jk) > hbatt(ji,jj) ) THEN 2324 2464 WRITE(ctmp1,*) 'ERROR zgr_sco : gdept > hbatt at point (i,j,k)= ', ji, jj, jk 2325 2465 WRITE(numout,*) 'ERROR zgr_sco : gdept > hbatt at point (i,j,k)= ', ji, jj, jk 2326 WRITE(numout,*) 'gdept',gdept_ n(ji,jj,:)2466 WRITE(numout,*) 'gdept',gdept_0(ji,jj,:) 2327 2467 CALL ctl_stop( ctmp1 ) 2328 2468 ENDIF -
branches/2016/dev_NOC_2016/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90
r6140 r7339 36 36 USE domvvl ! varying vertical mesh 37 37 USE iscplrst ! ice sheet coupling 38 USE wet_dry ! wetting and drying (needed for wad_istate) 38 39 ! 39 40 USE in_out_manager ! I/O manager … … 105 106 ELSEIF( cp_cfg == 'gyre' ) THEN 106 107 CALL istate_gyre ! GYRE configuration : start from pre-defined T-S fields 108 ELSEIF( cp_cfg == 'wad' ) THEN 109 CALL wad_istate ! WAD test configuration : start from pre-defined T-S fields and initial ssh slope 107 110 ELSE ! Initial T-S, U-V fields read in files 108 111 IF ( ln_tsd_init ) THEN ! read 3D T and S data at nit000 -
branches/2016/dev_NOC_2016/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90
r6152 r7339 432 432 INTEGER :: ji, jj, jk, jii, jjj ! dummy loop indices 433 433 REAL(wp) :: zcoef0, zuap, zvap, znad, ztmp ! temporary scalars 434 LOGICAL :: ll_tmp1, ll_tmp2 , ll_tmp3! local logical variables434 LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables 435 435 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhpi, zhpj 436 436 REAL(wp), POINTER, DIMENSION(:,:) :: zcpx, zcpy !W/D pressure filter … … 438 438 ! 439 439 CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj ) 440 IF( ln_wd) CALL wrk_alloc( jpi,jpj, zcpx, zcpy )440 IF( ln_wd ) CALL wrk_alloc( jpi,jpj, zcpx, zcpy ) 441 441 ! 442 442 IF( kt == nit000 ) THEN … … 451 451 ENDIF 452 452 ! 453 IF( ln_wd) THEN453 IF( ln_wd ) THEN 454 454 DO jj = 2, jpjm1 455 455 DO ji = 2, jpim1 456 ll_tmp1 = MIN(sshn(ji,jj), sshn(ji+1,jj)) > MAX(-bathy(ji,jj), -bathy(ji+1,jj)) 457 ll_tmp2 = MAX(sshn(ji,jj) + bathy(ji,jj), sshn(ji+1,jj) + bathy(ji+1,jj)) > rn_wdmin1 + rn_wdmin2 458 ll_tmp3 = MAX(sshn(ji,jj), sshn(ji+1,jj)) > MAX(-bathy(ji,jj), -bathy(ji+1,jj)) + & 459 & rn_wdmin1 + rn_wdmin2 460 461 IF(ll_tmp1.AND.ll_tmp2) THEN 456 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 457 & MAX( -bathy(ji,jj) , -bathy(ji+1,jj) ) .AND. & 458 & MAX( sshn(ji,jj) + bathy(ji,jj), sshn(ji+1,jj) + bathy(ji+1,jj) ) & 459 & > rn_wdmin1 + rn_wdmin2 460 ll_tmp2 = MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 461 & MAX( -bathy(ji,jj) , -bathy(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 462 463 IF(ll_tmp1) THEN 462 464 zcpx(ji,jj) = 1.0_wp 463 wduflt(ji,jj) = 1.0_wp 464 ELSE IF(ll_tmp3) THEN 465 ! no worries about sshn(ji+1,jj)-sshn(ji,jj) = 0, it won't happen ! here 466 zcpx(ji,jj) = ABS((sshn(ji+1,jj) + bathy(ji+1,jj) - sshn(ji,jj) - bathy(ji,jj)) / & 467 & (sshn(ji+1,jj) - sshn(ji,jj))) 468 wduflt(ji,jj) = 1.0_wp 465 ELSE IF(ll_tmp2) THEN 466 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 467 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + bathy(ji+1,jj) - sshn(ji,jj) - bathy(ji,jj)) & 468 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 469 469 ELSE 470 470 zcpx(ji,jj) = 0._wp 471 wduflt(ji,jj) = 0.0_wp472 471 END IF 473 472 474 ll_tmp1 = MIN(sshn(ji,jj), sshn(ji,jj+1)) > MAX(-bathy(ji,jj), -bathy(ji,jj+1)) 475 ll_tmp2 = MAX(sshn(ji,jj) + bathy(ji,jj), sshn(ji,jj+1) + bathy(ji,jj+1)) > rn_wdmin1 + rn_wdmin2 476 ll_tmp3 = MAX(sshn(ji,jj), sshn(ji,jj+1)) > MAX(-bathy(ji,jj), -bathy(ji,jj+1)) + & 477 & rn_wdmin1 + rn_wdmin2 478 479 IF(ll_tmp1.AND.ll_tmp2) THEN 473 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 474 & MAX( -bathy(ji,jj) , -bathy(ji,jj+1) ) .AND. & 475 & MAX( sshn(ji,jj) + bathy(ji,jj), sshn(ji,jj+1) + bathy(ji,jj+1) ) & 476 & > rn_wdmin1 + rn_wdmin2 477 ll_tmp2 = MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 478 & MAX( -bathy(ji,jj) , -bathy(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 479 480 IF(ll_tmp1) THEN 480 481 zcpy(ji,jj) = 1.0_wp 481 wdvflt(ji,jj) = 1.0_wp 482 ELSE IF(ll_tmp3) THEN 483 ! no worries about sshn(ji,jj+1)-sshn(ji,jj) = 0, it won't happen ! here 484 zcpy(ji,jj) = ABS((sshn(ji,jj+1) + bathy(ji,jj+1) - sshn(ji,jj) - bathy(ji,jj)) / & 485 & (sshn(ji,jj+1) - sshn(ji,jj))) 486 wdvflt(ji,jj) = 1.0_wp 482 ELSE IF(ll_tmp2) THEN 483 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 484 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + bathy(ji,jj+1) - sshn(ji,jj) - bathy(ji,jj)) & 485 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 487 486 ELSE 488 487 zcpy(ji,jj) = 0._wp 489 wdvflt(ji,jj) = 0.0_wp490 488 END IF 491 489 END DO 492 490 END DO 493 491 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp ) 494 ENDIF 495 492 END IF 496 493 497 494 ! Surface value … … 510 507 511 508 512 IF( ln_wd) THEN509 IF( ln_wd ) THEN 513 510 514 511 zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) … … 541 538 & * ( gde3w_n(ji ,jj+1,jk) - gde3w_n(ji,jj,jk) ) * r1_e2v(ji,jj) 542 539 543 IF( ln_wd) THEN540 IF( ln_wd ) THEN 544 541 zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 545 542 zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) … … 556 553 ! 557 554 CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj ) 558 IF( ln_wd) CALL wrk_dealloc( jpi,jpj, zcpx, zcpy )555 IF( ln_wd ) CALL wrk_dealloc( jpi,jpj, zcpx, zcpy ) 559 556 ! 560 557 END SUBROUTINE hpg_sco … … 701 698 CALL wrk_alloc( jpi, jpj, jpk, drhox, drhoy, drhoz, drhou, drhov, drhow ) 702 699 CALL wrk_alloc( jpi, jpj, jpk, rho_i, rho_j, rho_k, zhpi, zhpj ) 703 IF( ln_wd) CALL wrk_alloc( jpi,jpj, zcpx, zcpy )704 ! 705 ! 706 IF( ln_wd) THEN700 IF( ln_wd ) CALL wrk_alloc( jpi,jpj, zcpx, zcpy ) 701 ! 702 ! 703 IF( ln_wd ) THEN 707 704 DO jj = 2, jpjm1 708 705 DO ji = 2, jpim1 709 ll_tmp1 = MIN(sshn(ji,jj), sshn(ji+1,jj)) > MAX(-bathy(ji,jj), -bathy(ji+1,jj)) & 710 & .and. MAX(sshn(ji,jj) + bathy(ji,jj), sshn(ji+1,jj) + bathy(ji+1,jj)) & 711 & > rn_wdmin1 + rn_wdmin2 712 ll_tmp2 = MAX(sshn(ji,jj), sshn(ji+1,jj)) > MAX(-bathy(ji,jj), -bathy(ji+1,jj)) +& 713 & rn_wdmin1 + rn_wdmin2 706 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 707 & MAX( -bathy(ji,jj) , -bathy(ji+1,jj) ) .AND. & 708 & MAX( sshn(ji,jj) + bathy(ji,jj), sshn(ji+1,jj) + bathy(ji+1,jj) ) & 709 & > rn_wdmin1 + rn_wdmin2 710 ll_tmp2 = MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 711 & MAX( -bathy(ji,jj) , -bathy(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 714 712 715 713 IF(ll_tmp1) THEN 716 714 zcpx(ji,jj) = 1.0_wp 717 715 ELSE IF(ll_tmp2) THEN 718 ! no worries about sshn(ji+1,jj)-sshn(ji,jj) = 0, it won't happen ! here719 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + bathy(ji+1,jj) - sshn(ji,jj) - bathy(ji,jj)) /&720 & (sshn(ji+1,jj) - sshn(ji,jj)))716 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 717 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + bathy(ji+1,jj) - sshn(ji,jj) - bathy(ji,jj)) & 718 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 721 719 ELSE 722 720 zcpx(ji,jj) = 0._wp 723 721 END IF 724 722 725 ll_tmp1 = MIN(sshn(ji,jj), sshn(ji,jj+1)) > MAX(-bathy(ji,jj), -bathy(ji,jj+1)) & 726 & .and. MAX(sshn(ji,jj) + bathy(ji,jj), sshn(ji,jj+1) + bathy(ji,jj+1)) & 727 & > rn_wdmin1 + rn_wdmin2 728 ll_tmp2 = MAX(sshn(ji,jj), sshn(ji,jj+1)) > MAX(-bathy(ji,jj), -bathy(ji,jj+1)) +& 729 & rn_wdmin1 + rn_wdmin2 723 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 724 & MAX( -bathy(ji,jj) , -bathy(ji,jj+1) ) .AND. & 725 & MAX( sshn(ji,jj) + bathy(ji,jj), sshn(ji,jj+1) + bathy(ji,jj+1) ) & 726 & > rn_wdmin1 + rn_wdmin2 727 ll_tmp2 = MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 728 & MAX( -bathy(ji,jj) , -bathy(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 730 729 731 730 IF(ll_tmp1) THEN 732 731 zcpy(ji,jj) = 1.0_wp 733 732 ELSE IF(ll_tmp2) THEN 734 ! no worries about sshn(ji,jj+1)-sshn(ji,jj) = 0, it won't happen ! here735 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + bathy(ji,jj+1) - sshn(ji,jj) - bathy(ji,jj)) /&736 & (sshn(ji,jj+1) - sshn(ji,jj)))733 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 734 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + bathy(ji,jj+1) - sshn(ji,jj) - bathy(ji,jj)) & 735 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 737 736 ELSE 738 737 zcpy(ji,jj) = 0._wp … … 741 740 END DO 742 741 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp ) 743 ENDIF 744 742 END IF 745 743 746 744 IF( kt == nit000 ) THEN … … 913 911 zhpi(ji,jj,1) = ( rho_k(ji+1,jj ,1) - rho_k(ji,jj,1) - rho_i(ji,jj,1) ) * r1_e1u(ji,jj) 914 912 zhpj(ji,jj,1) = ( rho_k(ji ,jj+1,1) - rho_k(ji,jj,1) - rho_j(ji,jj,1) ) * r1_e2v(ji,jj) 915 IF( ln_wd) THEN913 IF( ln_wd ) THEN 916 914 zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 917 915 zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) … … 936 934 & + ( ( rho_k(ji,jj+1,jk) - rho_k(ji,jj,jk ) ) & 937 935 & -( rho_j(ji,jj ,jk) - rho_j(ji,jj,jk-1) ) ) * r1_e2v(ji,jj) 938 IF( ln_wd) THEN936 IF( ln_wd ) THEN 939 937 zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 940 938 zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) … … 950 948 CALL wrk_dealloc( jpi, jpj, jpk, drhox, drhoy, drhoz, drhou, drhov, drhow ) 951 949 CALL wrk_dealloc( jpi, jpj, jpk, rho_i, rho_j, rho_k, zhpi, zhpj ) 952 IF( ln_wd) CALL wrk_dealloc( jpi,jpj, zcpx, zcpy )950 IF( ln_wd ) CALL wrk_dealloc( jpi,jpj, zcpx, zcpy ) 953 951 ! 954 952 END SUBROUTINE hpg_djc … … 987 985 CALL wrk_alloc( jpi,jpj,jpk, zdept, zrhh ) 988 986 CALL wrk_alloc( jpi,jpj, zsshu_n, zsshv_n ) 989 IF( ln_wd) CALL wrk_alloc( jpi,jpj, zcpx, zcpy )987 IF( ln_wd ) CALL wrk_alloc( jpi,jpj, zcpx, zcpy ) 990 988 ! 991 989 IF( kt == nit000 ) THEN … … 1000 998 IF( ln_linssh ) znad = 0._wp 1001 999 1002 IF( ln_wd) THEN1000 IF( ln_wd ) THEN 1003 1001 DO jj = 2, jpjm1 1004 1002 DO ji = 2, jpim1 1005 ll_tmp1 = MIN(sshn(ji,jj), sshn(ji+1,jj)) > MAX(-bathy(ji,jj), -bathy(ji+1,jj)) & 1006 & .and. MAX(sshn(ji,jj) + bathy(ji,jj), sshn(ji+1,jj) + bathy(ji+1,jj)) & 1007 & > rn_wdmin1 + rn_wdmin2 1008 ll_tmp2 = MAX(sshn(ji,jj), sshn(ji+1,jj)) > MAX(-bathy(ji,jj), -bathy(ji+1,jj)) +& 1009 & rn_wdmin1 + rn_wdmin2 1003 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1004 & MAX( -bathy(ji,jj) , -bathy(ji+1,jj) ) .AND. & 1005 & MAX( sshn(ji,jj) + bathy(ji,jj), sshn(ji+1,jj) + bathy(ji+1,jj) ) & 1006 & > rn_wdmin1 + rn_wdmin2 1007 ll_tmp2 = MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 1008 & MAX( -bathy(ji,jj) , -bathy(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 1010 1009 1011 1010 IF(ll_tmp1) THEN 1012 1011 zcpx(ji,jj) = 1.0_wp 1013 1012 ELSE IF(ll_tmp2) THEN 1014 ! no worries about sshn(ji+1,jj)-sshn(ji,jj) = 0, it won't happen ! here1015 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + bathy(ji+1,jj) - sshn(ji,jj) - bathy(ji,jj)) /&1016 & (sshn(ji+1,jj) - sshn(ji,jj)))1013 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 1014 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + bathy(ji+1,jj) - sshn(ji,jj) - bathy(ji,jj)) & 1015 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 1017 1016 ELSE 1018 1017 zcpx(ji,jj) = 0._wp 1019 1018 END IF 1020 1019 1021 ll_tmp1 = MIN(sshn(ji,jj), sshn(ji,jj+1)) > MAX(-bathy(ji,jj), -bathy(ji,jj+1)) & 1022 & .and. MAX(sshn(ji,jj) + bathy(ji,jj), sshn(ji,jj+1) + bathy(ji,jj+1)) & 1023 & > rn_wdmin1 + rn_wdmin2 1024 ll_tmp2 = MAX(sshn(ji,jj), sshn(ji,jj+1)) > MAX(-bathy(ji,jj), -bathy(ji,jj+1)) +& 1025 & rn_wdmin1 + rn_wdmin2 1026 1027 IF(ll_tmp1.OR.ll_tmp2) THEN 1020 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1021 & MAX( -bathy(ji,jj) , -bathy(ji,jj+1) ) .AND. & 1022 & MAX( sshn(ji,jj) + bathy(ji,jj), sshn(ji,jj+1) + bathy(ji,jj+1) ) & 1023 & > rn_wdmin1 + rn_wdmin2 1024 ll_tmp2 = MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 1025 & MAX( -bathy(ji,jj) , -bathy(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 1026 1027 IF(ll_tmp1) THEN 1028 1028 zcpy(ji,jj) = 1.0_wp 1029 1029 ELSE IF(ll_tmp2) THEN 1030 ! no worries about sshn(ji,jj+1)-sshn(ji,jj) = 0, it won't happen ! here1031 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + bathy(ji,jj+1) - sshn(ji,jj) - bathy(ji,jj)) /&1032 & (sshn(ji,jj+1) - sshn(ji,jj)))1030 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 1031 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + bathy(ji,jj+1) - sshn(ji,jj) - bathy(ji,jj)) & 1032 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 1033 1033 ELSE 1034 1034 zcpy(ji,jj) = 0._wp … … 1037 1037 END DO 1038 1038 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp ) 1039 END IF1039 END IF 1040 1040 1041 1041 ! Clean 3-D work arrays … … 1221 1221 zdpdx2 = zcoef0 * r1_e1u(ji,jj) * REAL(jis-jid, wp) * (zpwes + zpwed) 1222 1222 ENDIF 1223 IF( ln_wd) THEN1223 IF( ln_wd ) THEN 1224 1224 zdpdx1 = zdpdx1 * zcpx(ji,jj) 1225 1225 zdpdx2 = zdpdx2 * zcpx(ji,jj) … … 1280 1280 zdpdy2 = zcoef0 * r1_e2v(ji,jj) * REAL(jjs-jjd, wp) * (zpnss + zpnsd ) 1281 1281 ENDIF 1282 IF( ln_wd) THEN1282 IF( ln_wd ) THEN 1283 1283 zdpdy1 = zdpdy1 * zcpy(ji,jj) 1284 1284 zdpdy2 = zdpdy2 * zcpy(ji,jj) … … 1295 1295 CALL wrk_dealloc( jpi,jpj,jpk, zdept, zrhh ) 1296 1296 CALL wrk_dealloc( jpi,jpj, zsshu_n, zsshv_n ) 1297 IF( ln_wd) CALL wrk_dealloc( jpi,jpj, zcpx, zcpy )1297 IF( ln_wd ) CALL wrk_dealloc( jpi,jpj, zcpx, zcpy ) 1298 1298 ! 1299 1299 END SUBROUTINE hpg_prj -
branches/2016/dev_NOC_2016/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90
r6140 r7339 205 205 ENDIF 206 206 ! ! Control of surface pressure gradient scheme options 207 ;nspg = np_NO ; ioptio = 0207 nspg = np_NO ; ioptio = 0 208 208 IF( ln_dynspg_exp ) THEN ; nspg = np_EXP ; ioptio = ioptio + 1 ; ENDIF 209 209 IF( ln_dynspg_ts ) THEN ; nspg = np_TS ; ioptio = ioptio + 1 ; ENDIF -
branches/2016/dev_NOC_2016/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90
r6152 r7339 156 156 REAL(wp), POINTER, DIMENSION(:,:) :: zhf 157 157 REAL(wp), POINTER, DIMENSION(:,:) :: zcpx, zcpy ! Wetting/Dying gravity filter coef. 158 REAL(wp), POINTER, DIMENSION(:,:) :: wduflt1, wdvflt1 ! Wetting/Dying velocity filter coef.159 158 !!---------------------------------------------------------------------- 160 159 ! … … 168 167 CALL wrk_alloc( jpi,jpj, zsshu_a, zsshv_a ) 169 168 CALL wrk_alloc( jpi,jpj, zhf ) 170 IF( ln_wd ) CALL wrk_alloc( jpi, jpj, zcpx, zcpy , wduflt1, wdvflt1)169 IF( ln_wd ) CALL wrk_alloc( jpi, jpj, zcpx, zcpy ) 171 170 ! 172 171 zmdi=1.e+20 ! missing data indicator for masking … … 374 373 IF( .NOT.ln_linssh ) THEN ! Variable volume : remove surface pressure gradient 375 374 IF( ln_wd ) THEN ! Calculating and applying W/D gravity filters 376 wduflt1(:,:) = 1.0_wp377 wdvflt1(:,:) = 1.0_wp378 DO jj = 2, jpjm1379 DO ji = 2, jpim1380 ll_tmp1 = MIN(sshn(ji,jj), sshn(ji+1,jj)) > MAX(-bathy(ji,jj), -bathy(ji+1,jj))&381 & .and. MAX(sshn(ji,jj) + bathy(ji,jj), sshn(ji+1,jj) + bathy(ji+1,jj)) &382 & > rn_wdmin1 + rn_wdmin2383 ll_tmp2 = MAX(sshn(ji,jj), sshn(ji+1,jj)) > MAX(-bathy(ji,jj), -bathy(ji+1,jj)) &384 & + rn_wdmin1 + rn_wdmin2375 DO jj = 2, jpjm1 376 DO ji = 2, jpim1 377 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & 378 & MAX( -bathy(ji,jj) , -bathy(ji+1,jj) ) .AND. & 379 & MAX( sshn(ji,jj) + bathy(ji,jj), sshn(ji+1,jj) + bathy(ji+1,jj) ) & 380 & > rn_wdmin1 + rn_wdmin2 381 ll_tmp2 = MAX( sshn(ji,jj) , sshn(ji+1,jj) ) > & 382 & MAX( -bathy(ji,jj) , -bathy(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 383 385 384 IF(ll_tmp1) THEN 386 zcpx(ji,jj) 387 ELSE IF(ll_tmp2) THEN388 ! no worries about sshn(ji+1,jj)-sshn(ji,jj) = 0, it won't happenhere389 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + bathy(ji+1,jj) - sshn(ji,jj) - bathy(ji,jj)) &390 & /(sshn(ji+1,jj) - sshn(ji,jj)))385 zcpx(ji,jj) = 1.0_wp 386 ELSE IF(ll_tmp2) THEN 387 ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here 388 zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + bathy(ji+1,jj) - sshn(ji,jj) - bathy(ji,jj)) & 389 & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) 391 390 ELSE 392 zcpx(ji,jj) = 0._wp 393 wduflt1(ji,jj) = 0.0_wp 391 zcpx(ji,jj) = 0._wp 394 392 END IF 395 396 ll_tmp1 = MIN(sshn(ji,jj), sshn(ji,jj+1)) > MAX(-bathy(ji,jj), -bathy(ji,jj+1)) & 397 & .and. MAX(sshn(ji,jj) + bathy(ji,jj), sshn(ji,jj+1) + bathy(ji,jj+1)) & 398 & > rn_wdmin1 + rn_wdmin2 399 ll_tmp2 = MAX(sshn(ji,jj), sshn(ji,jj+1)) > MAX(-bathy(ji,jj), -bathy(ji,jj+1)) & 400 & + rn_wdmin1 + rn_wdmin2 393 394 ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & 395 & MAX( -bathy(ji,jj) , -bathy(ji,jj+1) ) .AND. & 396 & MAX( sshn(ji,jj) + bathy(ji,jj), sshn(ji,jj+1) + bathy(ji,jj+1) ) & 397 & > rn_wdmin1 + rn_wdmin2 398 ll_tmp2 = MAX( sshn(ji,jj) , sshn(ji,jj+1) ) > & 399 & MAX( -bathy(ji,jj) , -bathy(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 400 401 401 IF(ll_tmp1) THEN 402 zcpy(ji,jj)= 1.0_wp403 ELSE IF(ll_tmp2) THEN404 ! no worries about sshn(ji,jj+1)-sshn(ji,jj) = 0, it won't happenhere405 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + bathy(ji,jj+1) - sshn(ji,jj) - bathy(ji,jj)) &406 & /(sshn(ji,jj+1) - sshn(ji,jj)))402 zcpy(ji,jj) = 1.0_wp 403 ELSE IF(ll_tmp2) THEN 404 ! no worries about sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here 405 zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + bathy(ji,jj+1) - sshn(ji,jj) - bathy(ji,jj)) & 406 & / (sshn(ji,jj+1) - sshn(ji,jj )) ) 407 407 ELSE 408 zcpy(ji,jj) = 0._wp 409 wdvflt1(ji,jj) = 0.0_wp 410 ENDIF 411 412 END DO 408 zcpy(ji,jj) = 0._wp 409 END IF 410 END DO 413 411 END DO 414 415 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp ) 416 412 417 413 DO jj = 2, jpjm1 418 414 DO ji = 2, jpim1 419 zu_trd(ji,jj) = (zu_trd(ji,jj) - grav * ( sshn(ji+1,jj ) - sshn(ji ,jj ) ) &420 & * r1_e1u(ji,jj) ) * zcpx(ji,jj) * wduflt1(ji,jj)421 zv_trd(ji,jj) = (zv_trd(ji,jj) - grav * ( sshn(ji ,jj+1) - sshn(ji ,jj ) ) &422 & * r1_e2v(ji,jj) ) * zcpy(ji,jj) * wdvflt1(ji,jj)415 zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj ) - sshn(ji ,jj ) ) & 416 & * r1_e1u(ji,jj) * zcpx(ji,jj) 417 zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( sshn(ji ,jj+1) - sshn(ji ,jj ) ) & 418 & * r1_e2v(ji,jj) * zcpy(ji,jj) 423 419 END DO 424 420 END DO … … 567 563 ENDIF 568 564 569 IF( ln_wd ) THEN !preserve the positivity of water depth570 !ssh[b,n,a] should have already been processed for this571 sshbb_e(:,:) = MAX(sshbb_e(:,:), rn_wdmin1 - bathy(:,:))572 sshb_e(:,:) = MAX(sshb_e(:,:) , rn_wdmin1 - bathy(:,:))573 ENDIF574 565 ! 575 566 IF (ln_bt_fw) THEN ! FORWARD integration: start from NOW fields … … 646 637 zhup2_e (:,:) = hu_0(:,:) + zwx(:,:) ! Ocean depth at U- and V-points 647 638 zhvp2_e (:,:) = hv_0(:,:) + zwy(:,:) 648 IF( ln_wd ) THEN649 zhup2_e(:,:) = MAX(zhup2_e (:,:), rn_wdmin1)650 zhvp2_e(:,:) = MAX(zhvp2_e (:,:), rn_wdmin1)651 END IF652 639 ELSE 653 640 zhup2_e (:,:) = hu_n(:,:) … … 701 688 END DO 702 689 END DO 690 703 691 ssha_e(:,:) = ( sshn_e(:,:) - rdtbt * ( zssh_frc(:,:) + zhdiv(:,:) ) ) * ssmask(:,:) 704 IF( ln_wd ) ssha_e(:,:) = MAX(ssha_e(:,:), rn_wdmin1 - bathy(:,:))692 705 693 CALL lbc_lnk( ssha_e, 'T', 1._wp ) 706 694 … … 749 737 zsshp2_e(:,:) = za0 * ssha_e(:,:) + za1 * sshn_e (:,:) & 750 738 & + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) 739 751 740 IF( ln_wd ) THEN ! Calculating and applying W/D gravity filters 752 wduflt1(:,:) = 1._wp753 wdvflt1(:,:) = 1._wp754 741 DO jj = 2, jpjm1 755 DO ji = 2, jpim1 756 ll_tmp1 = MIN( zsshp2_e(ji,jj), zsshp2_e(ji+1,jj) ) > MAX( -bathy(ji,jj), -bathy(ji+1,jj) ) & 757 & .AND. MAX( zsshp2_e(ji,jj) + bathy(ji,jj), zsshp2_e(ji+1,jj) + bathy(ji+1,jj) ) & 758 & > rn_wdmin1 + rn_wdmin2 759 ll_tmp2 = MAX( zsshp2_e(ji,jj), zsshp2_e(ji+1,jj) ) > MAX( -bathy(ji,jj), -bathy(ji+1,jj) ) & 760 & + rn_wdmin1 + rn_wdmin2 761 IF(ll_tmp1) THEN 762 zcpx(ji,jj) = 1._wp 763 ELSE IF(ll_tmp2) THEN 764 ! no worries about zsshp2_e(ji+1,jj)-zsshp2_e(ji,jj) = 0, it won't happen here 765 zcpx(ji,jj) = ABS( (zsshp2_e(ji+1,jj) + bathy(ji+1,jj) - zsshp2_e(ji,jj) - bathy(ji,jj)) & 766 & / (zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj)) ) 767 ELSE 768 zcpx(ji,jj) = 0._wp 769 wduflt1(ji,jj) = 0._wp 770 END IF 771 772 ll_tmp1 = MIN( zsshp2_e(ji,jj), zsshp2_e(ji,jj+1) ) > MAX( -bathy(ji,jj), -bathy(ji,jj+1) ) & 773 & .AND. MAX( zsshp2_e(ji,jj) + bathy(ji,jj), zsshp2_e(ji,jj+1) + bathy(ji,jj+1) ) & 774 & > rn_wdmin1 + rn_wdmin2 775 ll_tmp2 = MAX( zsshp2_e(ji,jj), zsshp2_e(ji,jj+1) ) > MAX( -bathy(ji,jj), -bathy(ji,jj+1) ) & 776 & + rn_wdmin1 + rn_wdmin2 777 IF(ll_tmp1) THEN 778 zcpy(ji,jj) = 1._wp 779 ELSE IF(ll_tmp2) THEN 780 ! no worries about zsshp2_e(ji,jj+1)-zsshp2_e(ji,jj) = 0, it won't happen here 781 zcpy(ji,jj) = ABS( (zsshp2_e(ji,jj+1) + bathy(ji,jj+1) - zsshp2_e(ji,jj) - bathy(ji,jj)) & 782 & / (zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj)) ) 783 ELSE 784 zcpy(ji,jj) = 0._wp 785 wdvflt1(ji,jj) = 0._wp 786 END IF 742 DO ji = 2, jpim1 743 ll_tmp1 = MIN( zsshp2_e(ji,jj) , zsshp2_e(ji+1,jj) ) > & 744 & MAX( -bathy(ji,jj) , -bathy(ji+1,jj) ) .AND. & 745 & MAX( zsshp2_e(ji,jj) + bathy(ji,jj), zsshp2_e(ji+1,jj) + bathy(ji+1,jj) ) & 746 & > rn_wdmin1 + rn_wdmin2 747 ll_tmp2 = MAX( zsshp2_e(ji,jj) , zsshp2_e(ji+1,jj) ) > & 748 & MAX( -bathy(ji,jj) , -bathy(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 749 750 IF(ll_tmp1) THEN 751 zcpx(ji,jj) = 1.0_wp 752 ELSE IF(ll_tmp2) THEN 753 ! no worries about zsshp2_e(ji+1,jj) - zsshp2_e(ji ,jj) = 0, it won't happen ! here 754 zcpx(ji,jj) = ABS( (zsshp2_e(ji+1,jj) + bathy(ji+1,jj) - zsshp2_e(ji,jj) - bathy(ji,jj)) & 755 & / (zsshp2_e(ji+1,jj) - zsshp2_e(ji ,jj)) ) 756 ELSE 757 zcpx(ji,jj) = 0._wp 758 END IF 759 760 ll_tmp1 = MIN( zsshp2_e(ji,jj) , zsshp2_e(ji,jj+1) ) > & 761 & MAX( -bathy(ji,jj) , -bathy(ji,jj+1) ) .AND. & 762 & MAX( zsshp2_e(ji,jj) + bathy(ji,jj), zsshp2_e(ji,jj+1) + bathy(ji,jj+1) ) & 763 & > rn_wdmin1 + rn_wdmin2 764 ll_tmp2 = MAX( zsshp2_e(ji,jj) , zsshp2_e(ji,jj+1) ) > & 765 & MAX( -bathy(ji,jj) , -bathy(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 766 767 IF(ll_tmp1) THEN 768 zcpy(ji,jj) = 1.0_wp 769 ELSE IF(ll_tmp2) THEN 770 ! no worries about zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj ) = 0, it won't happen ! here 771 zcpy(ji,jj) = ABS( (zsshp2_e(ji,jj+1) + bathy(ji,jj+1) - zsshp2_e(ji,jj) - bathy(ji,jj)) & 772 & / (zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj )) ) 773 ELSE 774 zcpy(ji,jj) = 0._wp 775 END IF 787 776 END DO 788 END DO 789 CALL lbc_lnk( zcpx, 'U', 1._wp ) ; CALL lbc_lnk( zcpy, 'V', 1._wp ) 790 ENDIF 777 END DO 778 END IF 791 779 ! 792 780 ! Compute associated depths at U and V points: … … 806 794 END DO 807 795 808 IF( ln_wd ) THEN809 zhust_e(:,:) = MAX(zhust_e (:,:), rn_wdmin1 )810 zhvst_e(:,:) = MAX(zhvst_e (:,:), rn_wdmin1 )811 END IF812 813 796 ENDIF 814 797 ! … … 888 871 zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 889 872 zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 890 zwx(ji,jj) = zu_spg * zcpx(ji,jj) 891 zwy(ji,jj) = zv_spg * zcpy(ji,jj) 873 zwx(ji,jj) = zu_spg * zcpx(ji,jj) * wdmask(ji,jj) * wdmask(ji+1, jj) 874 zwy(ji,jj) = zv_spg * zcpy(ji,jj) * wdmask(ji,jj) * wdmask(ji, jj+1) 892 875 END DO 893 876 END DO … … 927 910 DO ji = fs_2, fs_jpim1 ! vector opt. 928 911 929 IF( ln_wd ) THEN 930 zhura = MAX(hu_0(ji,jj) + zsshu_a(ji,jj), rn_wdmin1) 931 zhvra = MAX(hv_0(ji,jj) + zsshv_a(ji,jj), rn_wdmin1) 932 ELSE 933 zhura = hu_0(ji,jj) + zsshu_a(ji,jj) 934 zhvra = hv_0(ji,jj) + zsshv_a(ji,jj) 935 END IF 912 zhura = hu_0(ji,jj) + zsshu_a(ji,jj) 913 zhvra = hv_0(ji,jj) + zsshv_a(ji,jj) 936 914 zhura = ssumask(ji,jj)/(zhura + 1._wp - ssumask(ji,jj)) 937 915 zhvra = ssvmask(ji,jj)/(zhvra + 1._wp - ssvmask(ji,jj)) … … 953 931 ! 954 932 IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) 955 IF( ln_wd ) THEN 956 hu_e (:,:) = MAX(hu_0(:,:) + zsshu_a(:,:), rn_wdmin1) 957 hv_e (:,:) = MAX(hv_0(:,:) + zsshv_a(:,:), rn_wdmin1) 958 ELSE 959 hu_e (:,:) = hu_0(:,:) + zsshu_a(:,:) 960 hv_e (:,:) = hv_0(:,:) + zsshv_a(:,:) 961 END IF 933 hu_e (:,:) = hu_0(:,:) + zsshu_a(:,:) 934 hv_e (:,:) = hv_0(:,:) + zsshv_a(:,:) 962 935 hur_e(:,:) = ssumask(:,:) / ( hu_e(:,:) + 1._wp - ssumask(:,:) ) 963 936 hvr_e(:,:) = ssvmask(:,:) / ( hv_e(:,:) + 1._wp - ssvmask(:,:) ) … … 1024 997 ! 1025 998 ! Update barotropic trend: 1026 IF( ln_dynadv_vec .OR. ln_linssh ) THEN 1027 DO jk=1,jpkm1 1028 ua(:,:,jk) = ua(:,:,jk) + ( ua_b(:,:) - ub_b(:,:) ) * z1_2dt_b 1029 va(:,:,jk) = va(:,:,jk) + ( va_b(:,:) - vb_b(:,:) ) * z1_2dt_b 1030 END DO 999 IF(ln_wd) THEN 1000 IF( ln_dynadv_vec .OR. ln_linssh ) THEN 1001 DO jk=1,jpkm1 1002 ua(:,:,jk) = ua(:,:,jk) + ( ua_b(:,:) - ub_b(:,:) ) * z1_2dt_b * wdmask(:,:) 1003 va(:,:,jk) = va(:,:,jk) + ( va_b(:,:) - vb_b(:,:) ) * z1_2dt_b * wdmask(:,:) 1004 END DO 1005 ELSE 1006 ! At this stage, ssha has been corrected: compute new depths at velocity points 1007 DO jj = 1, jpjm1 1008 DO ji = 1, jpim1 ! NO Vector Opt. 1009 zsshu_a(ji,jj) = z1_2 * umask(ji,jj,1) * r1_e1e2u(ji,jj) & 1010 & * ( e1e2t(ji ,jj) * ssha(ji ,jj) & 1011 & + e1e2t(ji+1,jj) * ssha(ji+1,jj) ) 1012 zsshv_a(ji,jj) = z1_2 * vmask(ji,jj,1) * r1_e1e2v(ji,jj) & 1013 & * ( e1e2t(ji,jj ) * ssha(ji,jj ) & 1014 & + e1e2t(ji,jj+1) * ssha(ji,jj+1) ) 1015 END DO 1016 END DO 1017 CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 1018 ! 1019 DO jk=1,jpkm1 1020 ua(:,:,jk) = ua(:,:,jk) + r1_hu_n(:,:) * ( ua_b(:,:) - ub_b(:,:) * hu_b(:,:) ) * z1_2dt_b * wdmask(:,:) 1021 va(:,:,jk) = va(:,:,jk) + r1_hv_n(:,:) * ( va_b(:,:) - vb_b(:,:) * hv_b(:,:) ) * z1_2dt_b * wdmask(:,:) 1022 END DO 1023 ! Save barotropic velocities not transport: 1024 ua_b(:,:) = ua_b(:,:) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - ssumask(:,:) ) 1025 va_b(:,:) = va_b(:,:) / ( hv_0(:,:) + zsshv_a(:,:) + 1._wp - ssvmask(:,:) ) 1026 ENDIF 1031 1027 ELSE 1032 ! At this stage, ssha has been corrected: compute new depths at velocity points 1033 DO jj = 1, jpjm1 1034 DO ji = 1, jpim1 ! NO Vector Opt. 1035 zsshu_a(ji,jj) = z1_2 * umask(ji,jj,1) * r1_e1e2u(ji,jj) & 1036 & * ( e1e2t(ji ,jj) * ssha(ji ,jj) & 1037 & + e1e2t(ji+1,jj) * ssha(ji+1,jj) ) 1038 zsshv_a(ji,jj) = z1_2 * vmask(ji,jj,1) * r1_e1e2v(ji,jj) & 1039 & * ( e1e2t(ji,jj ) * ssha(ji,jj ) & 1040 & + e1e2t(ji,jj+1) * ssha(ji,jj+1) ) 1041 END DO 1042 END DO 1043 CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 1044 ! 1045 DO jk=1,jpkm1 1046 ua(:,:,jk) = ua(:,:,jk) + r1_hu_n(:,:) * ( ua_b(:,:) - ub_b(:,:) * hu_b(:,:) ) * z1_2dt_b 1047 va(:,:,jk) = va(:,:,jk) + r1_hv_n(:,:) * ( va_b(:,:) - vb_b(:,:) * hv_b(:,:) ) * z1_2dt_b 1048 END DO 1049 ! Save barotropic velocities not transport: 1050 ua_b(:,:) = ua_b(:,:) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - ssumask(:,:) ) 1051 va_b(:,:) = va_b(:,:) / ( hv_0(:,:) + zsshv_a(:,:) + 1._wp - ssvmask(:,:) ) 1052 ENDIF 1028 IF( ln_dynadv_vec .OR. ln_linssh ) THEN 1029 DO jk=1,jpkm1 1030 ua(:,:,jk) = ua(:,:,jk) + ( ua_b(:,:) - ub_b(:,:) ) * z1_2dt_b 1031 va(:,:,jk) = va(:,:,jk) + ( va_b(:,:) - vb_b(:,:) ) * z1_2dt_b 1032 END DO 1033 ELSE 1034 ! At this stage, ssha has been corrected: compute new depths at velocity points 1035 DO jj = 1, jpjm1 1036 DO ji = 1, jpim1 ! NO Vector Opt. 1037 zsshu_a(ji,jj) = z1_2 * umask(ji,jj,1) * r1_e1e2u(ji,jj) & 1038 & * ( e1e2t(ji ,jj) * ssha(ji ,jj) & 1039 & + e1e2t(ji+1,jj) * ssha(ji+1,jj) ) 1040 zsshv_a(ji,jj) = z1_2 * vmask(ji,jj,1) * r1_e1e2v(ji,jj) & 1041 & * ( e1e2t(ji,jj ) * ssha(ji,jj ) & 1042 & + e1e2t(ji,jj+1) * ssha(ji,jj+1) ) 1043 END DO 1044 END DO 1045 CALL lbc_lnk_multi( zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 1046 ! 1047 DO jk=1,jpkm1 1048 ua(:,:,jk) = ua(:,:,jk) + r1_hu_n(:,:) * ( ua_b(:,:) - ub_b(:,:) * hu_b(:,:) ) * z1_2dt_b 1049 va(:,:,jk) = va(:,:,jk) + r1_hv_n(:,:) * ( va_b(:,:) - vb_b(:,:) * hv_b(:,:) ) * z1_2dt_b 1050 END DO 1051 ! Save barotropic velocities not transport: 1052 ua_b(:,:) = ua_b(:,:) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - ssumask(:,:) ) 1053 va_b(:,:) = va_b(:,:) / ( hv_0(:,:) + zsshv_a(:,:) + 1._wp - ssvmask(:,:) ) 1054 ENDIF 1055 1056 END IF 1053 1057 ! 1054 1058 DO jk = 1, jpkm1 … … 1086 1090 CALL wrk_dealloc( jpi,jpj, zsshu_a, zsshv_a ) 1087 1091 CALL wrk_dealloc( jpi,jpj, zhf ) 1088 IF( ln_wd ) CALL wrk_dealloc( jpi, jpj, zcpx, zcpy , wduflt1, wdvflt1)1092 IF( ln_wd ) CALL wrk_dealloc( jpi, jpj, zcpx, zcpy ) 1089 1093 ! 1090 1094 IF ( ln_diatmb ) THEN -
branches/2016/dev_NOC_2016/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90
r6152 r7339 88 88 ENDIF 89 89 ! 90 CALL div_hor( kt ) ! Horizontal divergence 91 ! 92 z2dt = 2._wp * rdt ! set time step size (Euler/Leapfrog) 90 z2dt = 2._wp * rdt ! set time step size (Euler/Leapfrog) 93 91 IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt 92 zcoef = 0.5_wp * r1_rau0 94 93 95 94 ! !------------------------------! 96 95 ! ! After Sea Surface Height ! 97 96 ! !------------------------------! 97 IF(ln_wd) THEN 98 CALL wad_lmt(sshb, zcoef * (emp_b(:,:) + emp(:,:)), z2dt) 99 ENDIF 100 101 CALL div_hor( kt ) ! Horizontal divergence 102 ! 98 103 zhdiv(:,:) = 0._wp 99 104 DO jk = 1, jpkm1 ! Horizontal divergence of barotropic transports … … 104 109 ! compute the vertical velocity which can be used to compute the non-linear terms of the momentum equations. 105 110 ! 106 zcoef = 0.5_wp * r1_rau0107 108 IF(ln_wd) CALL wad_lmt(sshb, zcoef * (emp_b(:,:) + emp(:,:)), z2dt)109 110 111 ssha(:,:) = ( sshb(:,:) - z2dt * ( zcoef * ( emp_b(:,:) + emp(:,:) ) + zhdiv(:,:) ) ) * ssmask(:,:) 111 112 -
branches/2016/dev_NOC_2016/NEMOGCM/NEMO/OPA_SRC/DYN/wet_dry.F90
r6152 r7339 33 33 !! --------------------------------------------------------------------- 34 34 35 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wduflt, wdvflt !: u- and v- filter36 35 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdmask !: u- and v- limiter 37 36 … … 46 45 PUBLIC wad_lmt ! routine called by sshwzv.F90 47 46 PUBLIC wad_lmt_bt ! routine called by dynspg_ts.F90 47 PUBLIC wad_istate ! routine called by istate.F90 and domvvl.F90 48 48 49 49 !! * Substitutions … … 87 87 88 88 IF(ln_wd) THEN 89 ALLOCATE( wd uflt(jpi,jpj), wdvflt(jpi,jpj), wdmask(jpi,jpj), STAT=ierr )89 ALLOCATE( wdmask(jpi,jpj), STAT=ierr ) 90 90 IF( ierr /= 0 ) CALL ctl_stop('STOP', 'wad_init : Array allocation error') 91 91 ENDIF … … 145 145 ! Horizontal Flux in u and v direction 146 146 DO jk = 1, jpkm1 147 DO jj = 1, jpj m1148 DO ji = 1, jpi m1147 DO jj = 1, jpj 148 DO ji = 1, jpi 149 149 zflxu(ji,jj) = zflxu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk) * umask(ji,jj,jk) 150 150 zflxv(ji,jj) = zflxv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk) * vmask(ji,jj,jk) … … 156 156 zflxv(:,:) = zflxv(:,:) * e1v(:,:) 157 157 158 DO jj = 2, jpjm1 159 DO ji = 2, jpim1 158 wdmask(:,:) = 1 159 DO jj = 2, jpj 160 DO ji = 2, jpi 160 161 161 162 IF(tmask(ji, jj, 1) < 0.5_wp) CYCLE ! we don't care about land cells … … 168 169 169 170 zdep2 = bathy(ji,jj) + sshb1(ji,jj) - rn_wdmin1 170 IF(zdep2 <0._wp) THEN !add more safty, but not necessary171 IF(zdep2 .le. 0._wp) THEN !add more safty, but not necessary 171 172 !zdep2 = 0._wp 172 173 sshb1(ji,jj) = rn_wdmin1 - bathy(ji,jj) 174 wdmask(ji,jj) = 0._wp 173 175 END IF 174 176 ENDDO … … 183 185 zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) 184 186 185 DO jj = 2, jpj m1186 DO ji = 2, jpi m1187 DO jj = 2, jpj 188 DO ji = 2, jpi 187 189 188 wdmask(ji,jj) = 0189 190 IF(tmask(ji, jj, 1) < 0.5_wp) CYCLE 190 191 IF(bathy(ji,jj) > zdepwd) CYCLE … … 202 203 IF(zdep1 > zdep2) THEN 203 204 zflag = 1 204 wdmask(ji, jj) = 1205 wdmask(ji, jj) = 0 205 206 zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 206 207 zcoef = max(zcoef, 0._wp) … … 209 210 IF(zflxu1(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = zcoef 210 211 IF(zflxv1(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = zcoef 211 IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji -1,jj) = zcoef212 IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = zcoef 212 213 END IF 213 214 END DO ! ji loop … … 231 232 CALL lbc_lnk( un, 'U', -1. ) 232 233 CALL lbc_lnk( vn, 'V', -1. ) 234 ! 235 un_b(:,:) = un_b(:,:) * zwdlmtu(:, :) 236 vn_b(:,:) = vn_b(:,:) * zwdlmtv(:, :) 237 CALL lbc_lnk( un_b, 'U', -1. ) 238 CALL lbc_lnk( vn_b, 'V', -1. ) 233 239 234 240 IF(zflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt!!!' … … 291 297 zflxp(:,:) = 0._wp 292 298 zflxn(:,:) = 0._wp 293 !zflxu(:,:) = 0._wp294 !zflxv(:,:) = 0._wp295 299 296 300 zwdlmtu(:,:) = 1._wp … … 299 303 ! Horizontal Flux in u and v direction 300 304 301 !zflxu(:,:) = zflxu(:,:) * e2u(:,:) 302 !zflxv(:,:) = zflxv(:,:) * e1v(:,:) 303 304 DO jj = 2, jpjm1 305 DO ji = 2, jpim1 305 DO jj = 2, jpj 306 DO ji = 2, jpi 306 307 307 308 IF(tmask(ji, jj, 1) < 0.5_wp) CYCLE ! we don't care about land cells … … 314 315 315 316 zdep2 = bathy(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 316 IF(zdep2 < 0._wp) THEN !add more safty, but not necessary317 !zdep2 = 0._wp318 sshn_e(ji,jj) = rn_wdmin1 - bathy(ji,jj)319 END IF320 317 ENDDO 321 318 END DO … … 329 326 zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) 330 327 331 DO jj = 2, jpj m1332 DO ji = 2, jpi m1328 DO jj = 2, jpj 329 DO ji = 2, jpi 333 330 334 wdmask(ji,jj) = 0335 331 IF(tmask(ji, jj, 1) < 0.5_wp) CYCLE 336 332 IF(bathy(ji,jj) > zdepwd) CYCLE … … 349 345 IF(zdep1 > zdep2) THEN 350 346 zflag = 1 351 !wdmask(ji, jj) = 1352 347 zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 353 348 zcoef = max(zcoef, 0._wp) … … 356 351 IF(zflxu1(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = zcoef 357 352 IF(zflxv1(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = zcoef 358 IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji -1,jj) = zcoef353 IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = zcoef 359 354 END IF 360 355 END DO ! ji loop … … 379 374 IF(zflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt_bt!!!' 380 375 381 !IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) ! runoffs (update hdivn field)382 !IF( nn_cla == 1 ) CALL cla_div ( kt ) ! Cross Land Advection (update hdivn field)383 376 ! 384 377 ! … … 390 383 IF( nn_timing == 1 ) CALL timing_stop('wad_lmt') 391 384 END SUBROUTINE wad_lmt_bt 385 386 SUBROUTINE wad_istate 387 !!---------------------------------------------------------------------- 388 !! *** ROUTINE wad_istate *** 389 !! 390 !! ** Purpose : Initialization of the dynamics and tracers for WAD test 391 !! configurations (channels or bowls with initial ssh gradients) 392 !! 393 !! ** Method : - set temperature field 394 !! - set salinity field 395 !! - set ssh slope (needs to be repeated in domvvl_rst_init to 396 !! set vertical metrics ) 397 !!---------------------------------------------------------------------- 398 ! 399 INTEGER :: ji, jj ! dummy loop indices 400 REAL(wp) :: zi, zj 401 !!---------------------------------------------------------------------- 402 ! 403 ! Uniform T & S in all test cases 404 tsn(:,:,:,jp_tem) = 10._wp 405 tsb(:,:,:,jp_tem) = 10._wp 406 tsn(:,:,:,jp_sal) = 35._wp 407 tsb(:,:,:,jp_sal) = 35._wp 408 SELECT CASE ( jp_cfg ) 409 ! ! ==================== 410 CASE ( 1 ) ! WAD 1 configuration 411 ! ! ==================== 412 ! 413 IF(lwp) WRITE(numout,*) 414 IF(lwp) WRITE(numout,*) 'istate_wad : Closed box with EW linear bottom slope' 415 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 416 ! 417 do ji = 1,jpi 418 sshn(ji,:) = ( -5.5_wp + 5.5_wp*FLOAT(mig(ji))/FLOAT(jpidta-1))*tmask(ji,:,1) 419 end do 420 ! ! ==================== 421 CASE ( 2 ) ! WAD 2 configuration 422 ! ! ==================== 423 ! 424 IF(lwp) WRITE(numout,*) 425 IF(lwp) WRITE(numout,*) 'istate_wad : Parobolic EW channel, mid-range initial ssh slope' 426 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 427 ! 428 do ji = 1,jpi 429 sshn(ji,:) = ( -5.5_wp + 3.9_wp*FLOAT(jpidta - mig(ji))/FLOAT(jpidta-1))*tmask(ji,:,1) 430 end do 431 ! ! ==================== 432 CASE ( 3 ) ! WAD 3 configuration 433 ! ! ==================== 434 ! 435 IF(lwp) WRITE(numout,*) 436 IF(lwp) WRITE(numout,*) 'istate_wad : Parobolic EW channel, extreme initial ssh slope' 437 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 438 ! 439 do ji = 1,jpi 440 sshn(ji,:) = ( -7.5_wp + 6.9_wp*FLOAT(jpidta - mig(ji))/FLOAT(jpidta-1))*tmask(ji,:,1) 441 end do 442 443 ! 444 ! ! ==================== 445 CASE ( 4 ) ! WAD 4 configuration 446 ! ! ==================== 447 ! 448 IF(lwp) WRITE(numout,*) 449 IF(lwp) WRITE(numout,*) 'istate_wad : Parobolic bowl, mid-range initial ssh slope' 450 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 451 ! 452 DO ji = 1, jpi 453 zi = MAX(1.0-FLOAT((mig(ji)-25)**2)/400.0, 0.0 ) 454 DO jj = 1, jpj 455 zj = MAX(1.0-FLOAT((mjg(jj)-17)**2)/144.0, 0.0 ) 456 sshn(ji,jj) = -8.5_wp + 8.5_wp*zi*zj 457 END DO 458 END DO 459 460 ! 461 ! ! =========================== 462 CASE ( 5 ) ! WAD 5 configuration 463 ! ! ==================== 464 ! 465 IF(lwp) WRITE(numout,*) 466 IF(lwp) WRITE(numout,*) 'istate_wad : Double slope with shelf' 467 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 468 ! 469 ! Needed rn_wdmin2 increased to 0.01 for this case? 470 do ji = 1,jpi 471 sshn(ji,:) = ( -5.5_wp + 9.0_wp*FLOAT(mig(ji))/FLOAT(jpidta-1))*tmask(ji,:,1) 472 end do 473 474 ! 475 ! ! =========================== 476 CASE ( 6 ) ! WAD 6 configuration 477 ! ! ==================== 478 ! 479 IF(lwp) WRITE(numout,*) 480 IF(lwp) WRITE(numout,*) 'istate_wad : Parobolic EW channel with gaussian ridge' 481 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 482 ! 483 do ji = 1,jpi 484 !6a 485 sshn(ji,:) = ( -5.5_wp + 9.0_wp*FLOAT(jpidta - mig(ji))/FLOAT(jpidta-1))*tmask(ji,:,1) 486 !Some variations in initial slope that have been tested 487 !6b 488 !sshn(ji,:) = ( -5.5_wp + 6.5_wp*FLOAT(jpidta - mig(ji))/FLOAT(jpidta-1))*tmask(ji,:,1) 489 !6c 490 !sshn(ji,:) = ( -5.5_wp + 7.5_wp*FLOAT(jpidta - mig(ji))/FLOAT(jpidta-1))*tmask(ji,:,1) 491 !6d 492 !sshn(ji,:) = ( -4.5_wp + 8.0_wp*FLOAT(jpidta - mig(ji))/FLOAT(jpidta-1))*tmask(ji,:,1) 493 end do 494 495 ! 496 ! ! =========================== 497 CASE DEFAULT ! NONE existing configuration 498 ! ! =========================== 499 WRITE(ctmp1,*) 'WAD test with a ', jp_cfg,' option is not coded' 500 ! 501 CALL ctl_stop( ctmp1 ) 502 ! 503 END SELECT 504 ! 505 ! Apply minimum wetdepth criterion 506 ! 507 do jj = 1,jpj 508 do ji = 1,jpi 509 IF( bathy(ji,jj) + sshn(ji,jj) < rn_wdmin1 ) THEN 510 sshn(ji,jj) = tmask(ji,jj,1)*( rn_wdmin1 - bathy(ji,jj) ) 511 ENDIF 512 end do 513 end do 514 sshb = sshn 515 ssha = sshn 516 ! 517 END SUBROUTINE wad_istate 518 519 !!===================================================================== 392 520 END MODULE wet_dry -
branches/2016/dev_NOC_2016/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_fct.F90
r6140 r7339 149 149 DO jj = 2, jpjm1 150 150 DO ji = fs_2, fs_jpim1 ! vector opt. 151 ! total intermediate advective trends151 ! ! total intermediate advective trends 152 152 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 153 153 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 154 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 155 ! update and guess with monotonic sheme 156 !!gm why tmask added in the two following lines ??? the mask is done in tranxt ! 157 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra * tmask(ji,jj,jk) 158 zwi(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + p2dt * ztra ) * tmask(ji,jj,jk) 154 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 155 ! ! update and guess with monotonic sheme 156 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / e3t_n(ji,jj,jk) * tmask(ji,jj,jk) 157 zwi(ji,jj,jk) = ( e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt * ztra ) / e3t_a(ji,jj,jk) * tmask(ji,jj,jk) 159 158 END DO 160 159 END DO … … 163 162 ! 164 163 IF( l_trd ) THEN ! trend diagnostics (contribution of upstream fluxes) 165 ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:); ztrdz(:,:,:) = zwz(:,:,:)164 ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) 166 165 END IF 167 166 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) … … 364 363 ! 365 364 CALL wrk_alloc( jpi,jpj, zwx_sav, zwy_sav ) 366 CALL wrk_alloc( jpi,jpj, jpk,zwx, zwy, zwz, zwi, zhdiv, zwzts, zwz_sav )365 CALL wrk_alloc( jpi,jpj,jpk, zwx, zwy, zwz, zwi, zhdiv, zwzts, zwz_sav ) 367 366 CALL wrk_alloc( jpi,jpj,jpk,kjpt+1, ztrs ) 368 367 ! … … 436 435 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 437 436 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 438 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)437 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 439 438 ! ! update and guess with monotonic sheme 440 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra441 zwi(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + p2dt * ztra) * tmask(ji,jj,jk)439 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / e3t_n(ji,jj,jk) * tmask(ji,jj,jk) 440 zwi(ji,jj,jk) = ( e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt * ztra ) / e3t_a(ji,jj,jk) * tmask(ji,jj,jk) 442 441 END DO 443 442 END DO … … 488 487 zwz_sav(:,:,:) = zwz(:,:,:) 489 488 ztrs (:,:,:,1) = ptb(:,:,:,jn) 489 ztrs (:,:,1,2) = ptb(:,:,1,jn) 490 ztrs (:,:,1,3) = ptb(:,:,1,jn) 490 491 zwzts (:,:,:) = 0._wp 491 492 ! -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/DMP_TOOLS/src/zoom.F90
r4739 r7339 29 29 NAMELIST/nam_zoom_dmp/lzoom_n,lzoom_e,lzoom_w,lzoom_s 30 30 !!---------------------------------------------------------------------- 31 ! 32 IF( nn_timing == 1 ) CALL timing_start( 'dtacof_zoom') 33 ! 34 31 35 32 ! Read namelist 36 33 OPEN( UNIT=numnam, FILE='namelist', FORM='FORMATTED', STATUS='OLD' ) -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/cfg/variable.cfg
r6140 r7339 1 1 # name | units | axis | pt| interpolation | long name | standard name 2 X | 1| X | | | | projection_x_coordinate3 Y | 1| Y | | | | projection_y_coordinate4 Z | 1| Z | | | | projection_z_coordinate5 T | 1| T | | | | projection_t_coordinate2 X | unitless | X | | | | projection_x_coordinate 3 Y | unitless | Y | | | | projection_y_coordinate 4 Z | unitless | Z | | | | projection_z_coordinate 5 T | unitless | T | | | | projection_t_coordinate 6 6 nav_lon | degrees_east | XY | T | cubic | Longitude | longitude 7 7 nav_lat | degrees_north | XY | T | cubic | Latitude | latitude … … 43 43 kt | | | | | | 44 44 rdt | | | | | | 45 rdttra1 | | | | | | 45 46 utau_b | | XY | U | | |surface_downward_eastward_stress 46 47 vtau_b | | XY | V | | |surface_downward_northward_stress -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/Doxyfile
r5037 r7339 45 45 # quick idea about the purpose of the project. Keep the description short. 46 46 47 PROJECT_BRIEF = "System and Interface for oceanic REloca ble Nesting"47 PROJECT_BRIEF = "System and Interface for oceanic RElocatable Nesting" 48 48 49 49 # With the PROJECT_LOGO tag one can specify an logo or icon that is included in … … 2069 2069 # The default value is: NO. 2070 2070 2071 HAVE_DOT = YES2071 HAVE_DOT = NO 2072 2072 2073 2073 # The DOT_NUM_THREADS specifies the number of dot invocations doxygen is allowed -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/attribute.f90
r5617 r7339 83 83 !> @date November, 2014 84 84 !> - Fix memory leaks bug 85 !> @date September, 2015 86 !> - manage useless (dummy) attributes 85 87 ! 86 88 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 98 100 PUBLIC :: TATT !< attribute structure 99 101 102 PRIVATE :: cm_dumatt !< dummy attribute array 103 100 104 ! function and subroutine 101 105 PUBLIC :: att_init !< initialize attribute structure … … 105 109 PUBLIC :: att_get_index !< get attribute index, in an array of attribute structure 106 110 PUBLIC :: att_get_id !< get attribute id, read from file 111 PUBLIC :: att_get_dummy !< fill dummy attribute array 112 PUBLIC :: att_is_dummy !< check if attribute is defined as dummy attribute 107 113 108 114 PRIVATE :: att__clean_unit ! clean attribute strcuture … … 135 141 END TYPE TATT 136 142 143 CHARACTER(LEN=lc), DIMENSION(ip_maxdum), SAVE :: cm_dumatt !< dummy attribute 144 137 145 INTERFACE att_init 138 146 MODULE PROCEDURE att__init_c … … 1251 1259 1252 1260 END SUBROUTINE att__clean_arr 1261 !------------------------------------------------------------------- 1262 !> @brief This subroutine fill dummy attribute array 1263 ! 1264 !> @author J.Paul 1265 !> @date September, 2015 - Initial Version 1266 !> @date Marsh, 2016 1267 !> - close file (bugfix) 1268 ! 1269 !> @param[in] cd_dummy dummy configuration file 1270 !------------------------------------------------------------------- 1271 SUBROUTINE att_get_dummy( cd_dummy ) 1272 IMPLICIT NONE 1273 ! Argument 1274 CHARACTER(LEN=*), INTENT(IN) :: cd_dummy 1275 1276 ! local variable 1277 INTEGER(i4) :: il_fileid 1278 INTEGER(i4) :: il_status 1279 1280 LOGICAL :: ll_exist 1281 1282 ! loop indices 1283 ! namelist 1284 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumvar 1285 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumdim 1286 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumatt 1287 1288 !---------------------------------------------------------------- 1289 NAMELIST /namdum/ & !< dummy namelist 1290 & cn_dumvar, & !< variable name 1291 & cn_dumdim, & !< dimension name 1292 & cn_dumatt !< attribute name 1293 !---------------------------------------------------------------- 1294 1295 ! init 1296 cm_dumatt(:)='' 1297 1298 ! read namelist 1299 INQUIRE(FILE=TRIM(cd_dummy), EXIST=ll_exist) 1300 IF( ll_exist )THEN 1301 1302 il_fileid=fct_getunit() 1303 1304 OPEN( il_fileid, FILE=TRIM(cd_dummy), & 1305 & FORM='FORMATTED', & 1306 & ACCESS='SEQUENTIAL', & 1307 & STATUS='OLD', & 1308 & ACTION='READ', & 1309 & IOSTAT=il_status) 1310 CALL fct_err(il_status) 1311 IF( il_status /= 0 )THEN 1312 CALL logger_fatal("DIM GET DUMMY: opening "//TRIM(cd_dummy)) 1313 ENDIF 1314 1315 READ( il_fileid, NML = namdum ) 1316 cm_dumatt(:)=cn_dumatt(:) 1317 1318 CLOSE( il_fileid ) 1319 1320 ENDIF 1321 1322 END SUBROUTINE att_get_dummy 1323 !------------------------------------------------------------------- 1324 !> @brief This function check if attribute is defined as dummy attribute 1325 !> in configuraton file 1326 !> 1327 !> @author J.Paul 1328 !> @date September, 2015 - Initial Version 1329 ! 1330 !> @param[in] td_att attribute structure 1331 !> @return true if attribute is dummy attribute 1332 !------------------------------------------------------------------- 1333 FUNCTION att_is_dummy(td_att) 1334 IMPLICIT NONE 1335 1336 ! Argument 1337 TYPE(TATT), INTENT(IN) :: td_att 1338 1339 ! function 1340 LOGICAL :: att_is_dummy 1341 1342 ! loop indices 1343 INTEGER(i4) :: ji 1344 !---------------------------------------------------------------- 1345 1346 att_is_dummy=.FALSE. 1347 DO ji=1,ip_maxdum 1348 IF( fct_lower(td_att%c_name) == fct_lower(cm_dumatt(ji)) )THEN 1349 att_is_dummy=.TRUE. 1350 EXIT 1351 ENDIF 1352 ENDDO 1353 1354 END FUNCTION att_is_dummy 1253 1355 END MODULE att 1254 1356 -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/boundary.f90
r5609 r7339 482 482 !> ex : cn_north='index1,first1,last1(width)|index2,first2,last2' 483 483 !> 484 !> @ noteBoundaries are compute on T point, but expressed on U,V point.484 !> @warn Boundaries are compute on T point, but expressed on U,V point. 485 485 !> change will be done to get data on other point when need be. 486 486 !> -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/create_bathy.f90
r5617 r7339 8 8 !> @file 9 9 !> @brief 10 !> This program create fine grid bathymetry file.10 !> This program creates fine grid bathymetry file. 11 11 !> 12 12 !> @details … … 27 27 !> you could find a template of the namelist in templates directory. 28 28 !> 29 !> create_bathy.nam co mprise7 namelists:<br/>29 !> create_bathy.nam contains 7 namelists:<br/> 30 30 !> - logger namelist (namlog) 31 31 !> - config namelist (namcfg) … … 36 36 !> - output namelist (namout) 37 37 !> 38 !> @note39 !> All namelists have to be in file create_bathy.nam, however variables of40 !> those namelists are all optional.41 !>42 38 !> * _logger namelist (namlog)_:<br/> 43 39 !> - cn_logfile : log filename … … 49 45 !> - cn_varcfg : variable configuration file 50 46 !> (see ./SIREN/cfg/variable.cfg) 47 !> - cn_dumcfg : useless (dummy) configuration file, for useless 48 !> dimension or variable (see ./SIREN/cfg/dummy.cfg). 51 49 !> 52 50 !> * _coarse grid namelist (namcrs)_:<br/> … … 61 59 !> 62 60 !> * _variable namelist (namvar)_:<br/> 63 !> - cn_varinfo : list of variable and extra information about request(s)64 !> to be used.<br/>65 !> each elements of *cn_varinfo* is a string character66 !> (separated by ',').<br/>67 !> it is composed of the variable name follow by ':',68 !> then request(s) to be used on this variable.<br/>69 !> request could be:70 !> - int = interpolation method71 !> - ext = extrapolation method72 !> - flt = filter method73 !> - min = minimum value74 !> - max = maximum value75 !> - unt = new units76 !> - unf = unit scale factor (linked to new units)77 !>78 !> requests must be separated by ';'.<br/>79 !> order of requests does not matter.<br/>80 !>81 !> informations about available method could be find in @ref interp,82 !> @ref extrap and @ref filter modules.<br/>83 !> Example: 'Bathymetry: flt=2*hamming(2,3); min=0'84 !> @note85 !> If you do not specify a method which is required,86 !> default one is apply.87 !> @warning88 !> variable name must be __Bathymetry__ here.89 61 !> - cn_varfile : list of variable, and corresponding file.<br/> 90 62 !> *cn_varfile* is the path and filename of the file where find … … 108 80 !> - 'Bathymetry:5000,5000,5000/5000,3000,5000/5000,5000,5000' 109 81 !> 82 !> - cn_varinfo : list of variable and extra information about request(s) 83 !> to be used.<br/> 84 !> each elements of *cn_varinfo* is a string character 85 !> (separated by ',').<br/> 86 !> it is composed of the variable name follow by ':', 87 !> then request(s) to be used on this variable.<br/> 88 !> request could be: 89 !> - int = interpolation method 90 !> - ext = extrapolation method 91 !> - flt = filter method 92 !> - min = minimum value 93 !> - max = maximum value 94 !> - unt = new units 95 !> - unf = unit scale factor (linked to new units) 96 !> 97 !> requests must be separated by ';'.<br/> 98 !> order of requests does not matter.<br/> 99 !> 100 !> informations about available method could be find in @ref interp, 101 !> @ref extrap and @ref filter modules.<br/> 102 !> Example: 'Bathymetry: flt=2*hamming(2,3); min=0' 103 !> @note 104 !> If you do not specify a method which is required, 105 !> default one is apply. 106 !> @warning 107 !> variable name must be __Bathymetry__ here. 108 !> 110 109 !> * _nesting namelist (namnst)_:<br/> 111 110 !> - in_rhoi : refinement factor in i-direction … … 127 126 !> - extrapolate all land points. 128 127 !> - allow to change unit. 128 !> @date September, 2015 129 !> - manage useless (dummy) variable, attributes, and dimension 130 !> @date January,2016 131 !> - add create_bathy_check_depth as in create_boundary 132 !> - add create_bathy_check_time as in create_boundary 133 !> @date February, 2016 134 !> - do not closed sea for east-west cyclic domain 129 135 ! 130 136 !> @todo 131 !> - use create_bathy_check_depth as in create_boundary132 !> - use create_bathy_check_time as in create_boundary133 137 !> - check tl_multi is not empty 134 138 !> … … 167 171 INTEGER(i4) :: il_status 168 172 INTEGER(i4) :: il_fileid 169 INTEGER(i4) :: il_varid170 173 INTEGER(i4) :: il_attid 171 174 INTEGER(i4) :: il_imin0 … … 179 182 180 183 LOGICAL :: ll_exist 184 LOGICAL :: ll_fillclosed 181 185 182 186 TYPE(TMPP) :: tl_coord0 … … 208 212 ! namelist variable 209 213 ! namlog 210 CHARACTER(LEN=lc) :: cn_logfile = 'create_bathy.log'211 CHARACTER(LEN=lc) :: cn_verbosity = 'warning'212 INTEGER(i4) :: in_maxerror = 5214 CHARACTER(LEN=lc) :: cn_logfile = 'create_bathy.log' 215 CHARACTER(LEN=lc) :: cn_verbosity = 'warning' 216 INTEGER(i4) :: in_maxerror = 5 213 217 214 218 ! namcfg 215 CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' 219 CHARACTER(LEN=lc) :: cn_varcfg = './cfg/variable.cfg' 220 CHARACTER(LEN=lc) :: cn_dumcfg = './cfg/dummy.cfg' 216 221 217 222 ! namcrs 218 CHARACTER(LEN=lc) :: cn_coord0 = ''219 INTEGER(i4) :: in_perio0 = -1223 CHARACTER(LEN=lc) :: cn_coord0 = '' 224 INTEGER(i4) :: in_perio0 = -1 220 225 221 226 ! namfin 222 CHARACTER(LEN=lc) :: cn_coord1 = ''223 INTEGER(i4) :: in_perio1 = -1224 LOGICAL :: ln_fillclosed = .TRUE.227 CHARACTER(LEN=lc) :: cn_coord1 = '' 228 INTEGER(i4) :: in_perio1 = -1 229 LOGICAL :: ln_fillclosed = .TRUE. 225 230 226 231 ! namvar 232 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = '' 227 233 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' 228 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = ''229 234 230 235 ! namnst 231 INTEGER(i4) :: in_rhoi = 1232 INTEGER(i4) :: in_rhoj = 1236 INTEGER(i4) :: in_rhoi = 1 237 INTEGER(i4) :: in_rhoj = 1 233 238 234 239 ! namout 235 CHARACTER(LEN=lc) :: cn_fileout = 'bathy_fine.nc'240 CHARACTER(LEN=lc) :: cn_fileout = 'bathy_fine.nc' 236 241 !------------------------------------------------------------------- 237 242 … … 242 247 243 248 NAMELIST /namcfg/ & !< configuration namelist 244 & cn_varcfg !< variable configuration file 249 & cn_varcfg, & !< variable configuration file 250 & cn_dumcfg !< dummy configuration file 245 251 246 252 NAMELIST /namcrs/ & !< coarse grid namelist … … 254 260 255 261 NAMELIST /namvar/ & !< variable namelist 256 & cn_var info, & !< list of variable and interpolation method to be used. (ex: 'votemper:linear','vosaline:cubic' )257 & cn_var file !< list of variable file262 & cn_varfile, & !< list of variable file 263 & cn_varinfo !< list of variable and interpolation method to be used. (ex: 'votemper:linear','vosaline:cubic' ) 258 264 259 265 NAMELIST /namnst/ & !< nesting namelist … … 302 308 CALL var_def_extra(TRIM(cn_varcfg)) 303 309 310 ! get dummy variable 311 CALL var_get_dummy(TRIM(cn_dumcfg)) 312 ! get dummy dimension 313 CALL dim_get_dummy(TRIM(cn_dumcfg)) 314 ! get dummy attribute 315 CALL att_get_dummy(TRIM(cn_dumcfg)) 316 304 317 READ( il_fileid, NML = namcrs ) 305 318 READ( il_fileid, NML = namfin ) … … 309 322 ! match variable with file 310 323 tl_multi=multi_init(cn_varfile) 311 324 312 325 READ( il_fileid, NML = namnst ) 313 326 READ( il_fileid, NML = namout ) … … 322 335 323 336 PRINT *,"ERROR in create_bathy: can't find "//TRIM(cl_namelist) 337 STOP 324 338 325 339 ENDIF … … 343 357 & "check namelist") 344 358 ENDIF 359 360 ! do not closed sea for east-west cyclic domain 361 ll_fillclosed=ln_fillclosed 362 IF( tl_coord1%i_perio == 1 ) ll_fillclosed=.FALSE. 345 363 346 364 ! check … … 417 435 418 436 ! get or check depth value 419 IF( tl_multi%t_mpp(ji)%t_proc(1)%i_depthid /= 0 )THEN 420 il_varid=tl_multi%t_mpp(ji)%t_proc(1)%i_depthid 421 IF( ASSOCIATED(tl_depth%d_value) )THEN 422 tl_tmp=iom_mpp_read_var(tl_mpp,il_varid) 423 IF( ANY( tl_depth%d_value(:,:,:,:) /= & 424 & tl_tmp%d_value(:,:,:,:) ) )THEN 425 CALL logger_fatal("CREATE BATHY: depth value from "//& 426 & TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//& 427 & " to those from former file(s).") 428 ENDIF 429 CALL var_clean(tl_tmp) 430 ELSE 431 tl_depth=iom_mpp_read_var(tl_mpp,il_varid) 432 ENDIF 433 ENDIF 437 CALL create_bathy_check_depth( tl_mpp, tl_depth ) 434 438 435 439 ! get or check time value 436 IF( tl_multi%t_mpp(ji)%t_proc(1)%i_timeid /= 0 )THEN 437 il_varid=tl_multi%t_mpp(ji)%t_proc(1)%i_timeid 438 IF( ASSOCIATED(tl_time%d_value) )THEN 439 tl_tmp=iom_mpp_read_var(tl_mpp,il_varid) 440 IF( ANY( tl_time%d_value(:,:,:,:) /= & 441 & tl_tmp%d_value(:,:,:,:) ) )THEN 442 CALL logger_fatal("CREATE BATHY: time value from "//& 443 & TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//& 444 & " to those from former file(s).") 445 ENDIF 446 CALL var_clean(tl_tmp) 447 ELSE 448 tl_time=iom_mpp_read_var(tl_mpp,il_varid) 449 ENDIF 450 ENDIF 440 CALL create_bathy_check_time( tl_mpp, tl_time ) 451 441 452 442 ! close mpp file 453 443 CALL iom_mpp_close(tl_mpp) 454 444 455 IF( ANY( tl_mpp%t_dim(1:2)%i_len /=&456 & tl_coord0%t_dim(1:2)%i_len) )THEN445 IF( ANY(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len).OR.& 446 & ALL(il_rho(:)==1) )THEN 457 447 !- extract bathymetry from fine grid bathymetry 458 448 DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar … … 505 495 506 496 ! fill closed sea 507 IF( l n_fillclosed )THEN497 IF( ll_fillclosed )THEN 508 498 ALLOCATE( il_mask(tl_var(jk)%t_dim(1)%i_len, & 509 499 & tl_var(jk)%t_dim(2)%i_len) ) … … 526 516 & dl_minbat <= 0._dp )THEN 527 517 CALL logger_debug("CREATE BATHY: min value "//TRIM(fct_str(dl_minbat))) 528 CALL logger_ error("CREATE BATHY: Bathymetry has value <= 0")518 CALL logger_fatal("CREATE BATHY: Bathymetry has value <= 0") 529 519 ENDIF 530 520 … … 973 963 CALL dom_del_extra( tl_var, tl_dom, il_rho(:) ) 974 964 965 CALL dom_clean_extra( tl_dom ) 966 975 967 !- add ghost cell 976 968 CALL grid_add_ghost(tl_var,tl_dom%i_ghost(:,:)) … … 1109 1101 1110 1102 END SUBROUTINE create_bathy_interp 1103 !------------------------------------------------------------------- 1104 !> @brief 1105 !> This subroutine get depth variable value in an open mpp structure 1106 !> and check if agree with already input depth variable. 1107 !> 1108 !> @details 1109 !> 1110 !> @author J.Paul 1111 !> @date January, 2016 - Initial Version 1112 !> 1113 !> @param[in] td_mpp mpp structure 1114 !> @param[inout] td_depth depth variable structure 1115 !------------------------------------------------------------------- 1116 SUBROUTINE create_bathy_check_depth( td_mpp, td_depth ) 1117 1118 IMPLICIT NONE 1119 1120 ! Argument 1121 TYPE(TMPP) , INTENT(IN ) :: td_mpp 1122 TYPE(TVAR) , INTENT(INOUT) :: td_depth 1123 1124 ! local variable 1125 INTEGER(i4) :: il_varid 1126 TYPE(TVAR) :: tl_depth 1127 ! loop indices 1128 !---------------------------------------------------------------- 1129 1130 ! get or check depth value 1131 IF( td_mpp%t_proc(1)%i_depthid /= 0 )THEN 1132 1133 il_varid=td_mpp%t_proc(1)%i_depthid 1134 IF( ASSOCIATED(td_depth%d_value) )THEN 1135 1136 tl_depth=iom_mpp_read_var(td_mpp, il_varid) 1137 1138 IF( ANY( td_depth%d_value(:,:,:,:) /= & 1139 & tl_depth%d_value(:,:,:,:) ) )THEN 1140 1141 CALL logger_warn("CREATE BATHY: depth value from "//& 1142 & TRIM(td_mpp%c_name)//" not conform "//& 1143 & " to those from former file(s).") 1144 1145 ENDIF 1146 CALL var_clean(tl_depth) 1147 1148 ELSE 1149 td_depth=iom_mpp_read_var(td_mpp,il_varid) 1150 ENDIF 1151 1152 ENDIF 1153 1154 END SUBROUTINE create_bathy_check_depth 1155 !------------------------------------------------------------------- 1156 !> @brief 1157 !> This subroutine get date and time in an open mpp structure 1158 !> and check if agree with date and time already read. 1159 !> 1160 !> @details 1161 !> 1162 !> @author J.Paul 1163 !> @date January, 2016 - Initial Version 1164 !> 1165 !> @param[in] td_mpp mpp structure 1166 !> @param[inout] td_time time variable structure 1167 !------------------------------------------------------------------- 1168 SUBROUTINE create_bathy_check_time( td_mpp, td_time ) 1169 1170 IMPLICIT NONE 1171 1172 ! Argument 1173 TYPE(TMPP), INTENT(IN ) :: td_mpp 1174 TYPE(TVAR), INTENT(INOUT) :: td_time 1175 1176 ! local variable 1177 INTEGER(i4) :: il_varid 1178 TYPE(TVAR) :: tl_time 1179 1180 TYPE(TDATE) :: tl_date1 1181 TYPE(TDATE) :: tl_date2 1182 ! loop indices 1183 !---------------------------------------------------------------- 1184 1185 ! get or check depth value 1186 IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN 1187 1188 il_varid=td_mpp%t_proc(1)%i_timeid 1189 IF( ASSOCIATED(td_time%d_value) )THEN 1190 1191 tl_time=iom_mpp_read_var(td_mpp, il_varid) 1192 1193 tl_date1=var_to_date(td_time) 1194 tl_date2=var_to_date(tl_time) 1195 IF( tl_date1 - tl_date2 /= 0 )THEN 1196 1197 CALL logger_warn("CREATE BATHY: date from "//& 1198 & TRIM(td_mpp%c_name)//" not conform "//& 1199 & " to those from former file(s).") 1200 1201 ENDIF 1202 CALL var_clean(tl_time) 1203 1204 ELSE 1205 td_time=iom_mpp_read_var(td_mpp,il_varid) 1206 ENDIF 1207 1208 ENDIF 1209 1210 END SUBROUTINE create_bathy_check_time 1111 1211 END PROGRAM create_bathy -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/create_coord.f90
r5609 r7339 9 9 !> @file 10 10 !> @brief 11 !> This program create fine grid coordinate file.11 !> This program creates fine grid coordinate file. 12 12 !> 13 13 !> @details … … 27 27 !> you could find a template of the namelist in templates directory. 28 28 !> 29 !> create_coord.nam co mprise6 namelists:<br/>29 !> create_coord.nam contains 6 namelists:<br/> 30 30 !> - logger namelist (namlog) 31 31 !> - config namelist (namcfg) … … 35 35 !> - output namelist (namout) 36 36 !> 37 !> @note38 !> All namelists have to be in file create_coord.nam,39 !> however variables of those namelists are all optional.40 !>41 37 !> * _logger namelist (namlog)_:<br/> 42 38 !> - cn_logfile : log filename … … 48 44 !> - cn_varcfg : variable configuration file 49 45 !> (see ./SIREN/cfg/variable.cfg) 46 !> - cn_dumcfg : useless (dummy) configuration file, for useless 47 !> dimension or variable (see ./SIREN/cfg/dummy.cfg). 50 48 !> 51 49 !> * _coarse grid namelist (namcrs)_:<br/> … … 64 62 !> - int = interpolation method 65 63 !> - ext = extrapolation method 66 !> - flt = filter method67 64 !> 68 65 !> requests must be separated by ';' .<br/> … … 72 69 !> @ref extrap and @ref filter modules.<br/> 73 70 !> 74 !> Example: ' votemper: int=linear; flt=hann(2,3); ext=dist_weight',75 !> ' vosaline: int=cubic'<br/>71 !> Example: 'glamt: int=linear; ext=dist_weight', 72 !> 'e1t: int=cubic/rhoi'<br/> 76 73 !> @note 77 74 !> If you do not specify a method which is required, … … 103 100 !> - compute offset considering grid point 104 101 !> - add global attributes in output file 102 !> @date September, 2015 103 !> - manage useless (dummy) variable, attributes, and dimension 105 104 !> 106 105 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 167 166 168 167 ! namcfg 169 CHARACTER(LEN=lc) :: cn_varcfg = '../cfg/variable.cfg' 168 CHARACTER(LEN=lc) :: cn_varcfg = './cfg/variable.cfg' 169 CHARACTER(LEN=lc) :: cn_dumcfg = './cfg/dummy.cfg' 170 170 171 171 ! namcrs … … 194 194 195 195 NAMELIST /namcfg/ & ! config namelist 196 & cn_varcfg !< variable configuration file 196 & cn_varcfg, & !< variable configuration file 197 & cn_dumcfg !< dummy configuration file 197 198 198 199 NAMELIST /namcrs/ & ! coarse grid namelist … … 254 255 CALL var_def_extra(TRIM(cn_varcfg)) 255 256 257 ! get dummy variable 258 CALL var_get_dummy(TRIM(cn_dumcfg)) 259 ! get dummy dimension 260 CALL dim_get_dummy(TRIM(cn_dumcfg)) 261 ! get dummy attribute 262 CALL att_get_dummy(TRIM(cn_dumcfg)) 263 256 264 READ( il_fileid, NML = namcrs ) 257 265 READ( il_fileid, NML = namvar ) … … 354 362 ENDDO 355 363 364 ! clean 365 CALL dom_clean_extra( tl_dom ) 366 356 367 ! close mpp files 357 368 CALL iom_dom_close(tl_coord0) … … 388 399 CALL file_add_att(tl_fileout, tl_att) 389 400 390 tl_att=att_init("src_i_indices",(/ in_imin0,in_imax0/))401 tl_att=att_init("src_i_indices",(/tl_dom%i_imin,tl_dom%i_imax/)) 391 402 CALL file_add_att(tl_fileout, tl_att) 392 tl_att=att_init("src_j_indices",(/ in_jmin0,in_jmax0/))403 tl_att=att_init("src_j_indices",(/tl_dom%i_jmin,tl_dom%i_jmax/)) 393 404 CALL file_add_att(tl_fileout, tl_att) 394 405 IF( .NOT. ALL(il_rho(:)==1) )THEN -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/create_restart.f90
r5617 r7339 9 9 !> @file 10 10 !> @brief 11 !> This program create restart file.11 !> This program creates restart file. 12 12 !> 13 13 !> @details 14 14 !> @section sec1 method 15 15 !> Variables could be extracted from fine grid file, interpolated from coarse 16 !> grid file or restart file , ormanually written.<br/>17 !> Then they are split over new decomposition.16 !> grid file or restart file. Variables could also be manually written.<br/> 17 !> Then they are split over new layout. 18 18 !> @note 19 19 !> method could be different for each variable. … … 28 28 !> you could find a template of the namelist in templates directory. 29 29 !> 30 !> create_restart.nam co mprise9 namelists:<br/>30 !> create_restart.nam contains 9 namelists:<br/> 31 31 !> - logger namelist (namlog) 32 32 !> - config namelist (namcfg) … … 39 39 !> - output namelist (namout) 40 40 !> 41 !> @note42 !> All namelists have to be in file create_restart.nam43 !> however variables of those namelists are all optional.44 !>45 41 !> * _logger namelist (namlog)_:<br/> 46 42 !> - cn_logfile : log filename … … 52 48 !> - cn_varcfg : variable configuration file 53 49 !> (see ./SIREN/cfg/variable.cfg) 50 !> - cn_dumcfg : useless (dummy) configuration file, for useless 51 !> dimension or variable (see ./SIREN/cfg/dummy.cfg). 54 52 !> 55 53 !> * _coarse grid namelist (namcrs):<br/> … … 82 80 !> 83 81 !> * _variable namelist (namvar)_:<br/> 84 !> - cn_varinfo : list of variable and extra information about request(s) 85 !> to be used.<br/> 86 !> each elements of *cn_varinfo* is a string character 87 !> (separated by ',').<br/> 88 !> it is composed of the variable name follow by ':', 89 !> then request(s) to be used on this variable.<br/> 90 !> request could be: 91 !> - int = interpolation method 92 !> - ext = extrapolation method 93 !> - flt = filter method 94 !> - min = minimum value 95 !> - max = maximum value 96 !> - unt = new units 97 !> - unf = unit scale factor (linked to new units) 98 !> 99 !> requests must be separated by ';'.<br/> 100 !> order of requests does not matter.<br/> 101 !> 102 !> informations about available method could be find in @ref interp, 103 !> @ref extrap and @ref filter.<br/> 104 !> Example: 'votemper: int=linear; flt=hann; ext=dist_weight','vosaline: int=cubic' 105 !> @note 106 !> If you do not specify a method which is required, 107 !> default one is apply. 108 !> - cn_varfile : list of variable, and corresponding file<br/> 82 !> - cn_varfile : list of variable, and associated file<br/> 109 83 !> *cn_varfile* is the path and filename of the file where find 110 84 !> variable.<br/> … … 131 105 !> - 'all:restart.dimg' 132 106 !> 107 !> - cn_varinfo : list of variable and extra information about request(s) 108 !> to be used.<br/> 109 !> each elements of *cn_varinfo* is a string character 110 !> (separated by ',').<br/> 111 !> it is composed of the variable name follow by ':', 112 !> then request(s) to be used on this variable.<br/> 113 !> request could be: 114 !> - int = interpolation method 115 !> - ext = extrapolation method 116 !> - flt = filter method 117 !> - min = minimum value 118 !> - max = maximum value 119 !> - unt = new units 120 !> - unf = unit scale factor (linked to new units) 121 !> 122 !> requests must be separated by ';'.<br/> 123 !> order of requests does not matter.<br/> 124 !> 125 !> informations about available method could be find in @ref interp, 126 !> @ref extrap and @ref filter.<br/> 127 !> Example: 'votemper: int=linear; flt=hann; ext=dist_weight', 128 !> 'vosaline: int=cubic' 129 !> @note 130 !> If you do not specify a method which is required, 131 !> default one is apply. 132 !> 133 133 !> * _nesting namelist (namnst)_:<br/> 134 134 !> - in_rhoi : refinement factor in i-direction 135 135 !> - in_rhoj : refinement factor in j-direction 136 136 !> @note 137 !> coarse grid indices will be deduced from fine grid137 !> coarse grid indices will be computed from fine grid 138 138 !> coordinate file. 139 139 !> … … 141 141 !> - cn_fileout : output file 142 142 !> - ln_extrap : extrapolate land point or not 143 !> - in_niproc : i-direction number of processor144 !> - in_njproc : j-direction numebr of processor143 !> - in_niproc : number of processor in i-direction 144 !> - in_njproc : number of processor in j-direction 145 145 !> - in_nproc : total number of processor to be used 146 146 !> - cn_type : output format ('dimg', 'cdf') … … 156 156 !> - extrapolate all land points, and add ln_extrap in namelist. 157 157 !> - allow to change unit. 158 !> @date September, 2015 159 !> - manage useless (dummy) variable, attributes, and dimension 158 160 !> 159 161 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 173 175 USE iom ! I/O manager 174 176 USE grid ! grid manager 175 USE vgrid 177 USE vgrid ! vertical grid manager 176 178 USE extrap ! extrapolation manager 177 179 USE interp ! interpolation manager … … 183 185 184 186 IMPLICIT NONE 185 186 187 187 188 ! local variable … … 212 213 213 214 LOGICAL :: ll_exist 215 LOGICAL :: ll_sameGrid 214 216 215 217 TYPE(TDOM) :: tl_dom1 … … 242 244 ! namelist variable 243 245 ! namlog 244 CHARACTER(LEN=lc) :: cn_logfile = 'create_restart.log'245 CHARACTER(LEN=lc) :: cn_verbosity = 'warning'246 INTEGER(i4) :: in_maxerror = 5246 CHARACTER(LEN=lc) :: cn_logfile = 'create_restart.log' 247 CHARACTER(LEN=lc) :: cn_verbosity = 'warning' 248 INTEGER(i4) :: in_maxerror = 5 247 249 248 250 ! namcfg 249 CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' 251 CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' 252 CHARACTER(LEN=lc) :: cn_dumcfg = 'dummy.cfg' 250 253 251 254 ! namcrs 252 CHARACTER(LEN=lc) :: cn_coord0 = ''253 INTEGER(i4) :: in_perio0 = -1255 CHARACTER(LEN=lc) :: cn_coord0 = '' 256 INTEGER(i4) :: in_perio0 = -1 254 257 255 258 ! namfin 256 CHARACTER(LEN=lc) :: cn_coord1 = ''257 CHARACTER(LEN=lc) :: cn_bathy1 = ''258 INTEGER(i4) :: in_perio1 = -1259 CHARACTER(LEN=lc) :: cn_coord1 = '' 260 CHARACTER(LEN=lc) :: cn_bathy1 = '' 261 INTEGER(i4) :: in_perio1 = -1 259 262 260 263 !namzgr 261 REAL(dp) :: dn_pp_to_be_computed = 0._dp262 REAL(dp) :: dn_ppsur= -3958.951371276829_dp263 REAL(dp) :: dn_ppa0 = 103.9530096000000_dp264 REAL(dp) :: dn_ppa1 = 2.4159512690000_dp265 REAL(dp) :: dn_ppa2 = 100.7609285000000_dp266 REAL(dp) :: dn_ppkth = 15.3510137000000_dp267 REAL(dp) :: dn_ppkth2 = 48.0298937200000_dp268 REAL(dp) :: dn_ppacr = 7.0000000000000_dp269 REAL(dp) :: dn_ppacr2= 13.000000000000_dp270 REAL(dp) :: dn_ppdzmin= 6._dp271 REAL(dp) :: dn_pphmax= 5750._dp272 INTEGER(i4) :: in_nlevel= 75264 REAL(dp) :: dn_pp_to_be_computed = 0._dp 265 REAL(dp) :: dn_ppsur = -3958.951371276829_dp 266 REAL(dp) :: dn_ppa0 = 103.953009600000_dp 267 REAL(dp) :: dn_ppa1 = 2.415951269000_dp 268 REAL(dp) :: dn_ppa2 = 100.760928500000_dp 269 REAL(dp) :: dn_ppkth = 15.351013700000_dp 270 REAL(dp) :: dn_ppkth2 = 48.029893720000_dp 271 REAL(dp) :: dn_ppacr = 7.000000000000_dp 272 REAL(dp) :: dn_ppacr2 = 13.000000000000_dp 273 REAL(dp) :: dn_ppdzmin = 6._dp 274 REAL(dp) :: dn_pphmax = 5750._dp 275 INTEGER(i4) :: in_nlevel = 75 273 276 274 277 !namzps 275 REAL(dp) :: dn_e3zps_min = 25._dp276 REAL(dp) :: dn_e3zps_rat = 0.2_dp278 REAL(dp) :: dn_e3zps_min = 25._dp 279 REAL(dp) :: dn_e3zps_rat = 0.2_dp 277 280 278 281 ! namvar 282 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = '' 279 283 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' 280 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = ''281 284 282 285 ! namnst 283 INTEGER(i4) :: in_rhoi = 0284 INTEGER(i4) :: in_rhoj = 0286 INTEGER(i4) :: in_rhoi = 0 287 INTEGER(i4) :: in_rhoj = 0 285 288 286 289 ! namout 287 CHARACTER(LEN=lc) :: cn_fileout = 'restart.nc'288 LOGICAL :: ln_extrap = .FALSE.289 INTEGER(i4) :: in_nproc = 0290 INTEGER(i4) :: in_niproc = 0291 INTEGER(i4) :: in_njproc = 0292 CHARACTER(LEN=lc) :: cn_type = ''290 CHARACTER(LEN=lc) :: cn_fileout = 'restart.nc' 291 LOGICAL :: ln_extrap = .FALSE. 292 INTEGER(i4) :: in_nproc = 0 293 INTEGER(i4) :: in_niproc = 0 294 INTEGER(i4) :: in_njproc = 0 295 CHARACTER(LEN=lc) :: cn_type = '' 293 296 294 297 !------------------------------------------------------------------- … … 300 303 301 304 NAMELIST /namcfg/ & !< configuration namelist 302 & cn_varcfg !< variable configuration file 305 & cn_varcfg, & !< variable configuration file 306 & cn_dumcfg !< dummy configuration file 303 307 304 308 NAMELIST /namcrs/ & !< coarse grid namelist … … 330 334 331 335 NAMELIST /namvar/ & !< variable namelist 332 & cn_var info, & !< list of variable and interpolation method to be used.333 & cn_var file !< list of variable file336 & cn_varfile, & !< list of variable file 337 & cn_varinfo !< list of variable and interpolation method to be used. 334 338 335 339 NAMELIST /namnst/ & !< nesting namelist … … 382 386 ! get variable extra information 383 387 CALL var_def_extra(TRIM(cn_varcfg)) 388 389 ! get dummy variable 390 CALL var_get_dummy(TRIM(cn_dumcfg)) 391 ! get dummy dimension 392 CALL dim_get_dummy(TRIM(cn_dumcfg)) 393 ! get dummy attribute 394 CALL att_get_dummy(TRIM(cn_dumcfg)) 384 395 385 396 READ( il_fileid, NML = namcrs ) … … 509 520 510 521 jvar=jvar+1 511 522 512 523 WRITE(*,'(2x,a,a)') "work on variable "//& 513 524 & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) … … 541 552 CALL iom_mpp_open(tl_mpp) 542 553 543 544 554 ! get or check depth value 545 555 CALL create_restart_check_depth( tl_mpp, tl_depth ) … … 551 561 CALL iom_mpp_close(tl_mpp) 552 562 553 IF( ANY( tl_mpp%t_dim(1:2)%i_len /=&554 & tl_coord0%t_dim(1:2)%i_len) )THEN563 IF( ANY(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len) .OR.& 564 & ALL(il_rho(:)==1) )THEN 555 565 !!! extract value from fine grid 556 566 557 IF( ANY( tl_mpp%t_dim(1:2)%i_len < =&567 IF( ANY( tl_mpp%t_dim(1:2)%i_len < & 558 568 & tl_coord1%t_dim(1:2)%i_len) )THEN 559 CALL logger_fatal("CREATE RESTART: dimension in file "//&569 CALL logger_fatal("CREATE RESTART: dimensions in file "//& 560 570 & TRIM(tl_mpp%c_name)//" smaller than those in fine"//& 561 571 & " grid coordinates.") 562 572 ENDIF 563 573 574 ! use coord0 instead of mpp for restart file case 575 ! (without lon,lat) 576 ll_sameGrid=.FALSE. 577 IF( ALL(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len) & 578 & )THEN 579 ll_sameGrid=.TRUE. 580 ENDIF 581 564 582 ! compute domain on fine grid 565 il_ind(:,:)=grid_get_coarse_index(tl_mpp, tl_coord1 ) 583 IF( ll_sameGrid )THEN 584 il_ind(:,:)=grid_get_coarse_index(tl_mpp, tl_coord1 ) 585 ELSE 586 il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1 ) 587 ENDIF 566 588 567 589 il_imin1=il_ind(1,1) ; il_imax1=il_ind(1,2) … … 569 591 570 592 !- check grid coincidence 571 CALL grid_check_coincidence( tl_mpp, tl_coord1, & 572 & il_imin1, il_imax1, & 573 & il_jmin1, il_jmax1, & 574 & il_rho(:) ) 593 IF( ll_sameGrid )THEN 594 CALL grid_check_coincidence( tl_mpp, tl_coord1, & 595 & il_imin1, il_imax1, & 596 & il_jmin1, il_jmax1, & 597 & il_rho(:) ) 598 ELSE 599 CALL grid_check_coincidence( tl_coord0, tl_coord1, & 600 & il_imin1, il_imax1, & 601 & il_jmin1, il_jmax1, & 602 & il_rho(:) ) 603 ENDIF 575 604 576 605 ! compute domain … … 754 783 755 784 DO ji=1,ip_maxdim 785 756 786 IF( tl_dim(ji)%l_use )THEN 757 787 CALL mpp_move_dim(tl_mppout, tl_dim(ji)) … … 763 793 END SELECT 764 794 ENDIF 795 765 796 ENDDO 766 797 … … 879 910 !> and with dimension of the coordinate file.<br/> 880 911 !> Then the variable array of value is split into equal subdomain. 881 !> Each subdomain is filled with the correspondingvalue of the matrix.912 !> Each subdomain is filled with the associated value of the matrix. 882 913 !> 883 914 !> @author J.Paul … … 1169 1200 & tl_depth%d_value(:,:,:,:) ) )THEN 1170 1201 1171 CALL logger_ fatal("CREATE BOUNDARY: depth value from "//&1172 & TRIM(t l_multi%t_mpp(ji)%c_name)//" not conform "//&1202 CALL logger_warn("CREATE BOUNDARY: depth value from "//& 1203 & TRIM(td_mpp%c_name)//" not conform "//& 1173 1204 & " to those from former file(s).") 1174 1205 … … 1226 1257 IF( tl_date1 - tl_date2 /= 0 )THEN 1227 1258 1228 CALL logger_ fatal("CREATE BOUNDARY: date from "//&1229 & TRIM(t l_multi%t_mpp(ji)%c_name)//" not conform "//&1259 CALL logger_warn("CREATE BOUNDARY: date from "//& 1260 & TRIM(td_mpp%c_name)//" not conform "//& 1230 1261 & " to those from former file(s).") 1231 1262 -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/dimension.f90
r5617 r7339 154 154 ! REVISION HISTORY: 155 155 !> @date November, 2013 - Initial Version 156 !> @date Spetember, 2015 157 !> - manage useless (dummy) dimension 156 158 !> 157 159 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 167 169 ! type and variable 168 170 PUBLIC :: TDIM !< dimension structure 171 172 PRIVATE :: cm_dumdim !< dummy dimension array 169 173 170 174 ! function and subroutine … … 182 186 PUBLIC :: dim_get_index !< get dimension index in array of dimension structure 183 187 PUBLIC :: dim_get_id !< get dimension id in array of dimension structure 188 PUBLIC :: dim_get_dummy !< fill dummy dimension array 189 PUBLIC :: dim_is_dummy !< check if dimension is defined as dummy dimension 184 190 185 191 PRIVATE :: dim__reshape_2xyzt_dp ! reshape real(8) 4D array to ('x','y','z','t') … … 209 215 END TYPE 210 216 217 CHARACTER(LEN=lc), DIMENSION(ip_maxdum), SAVE :: cm_dumdim !< dummy dimension 218 211 219 INTERFACE dim_print 212 220 MODULE PROCEDURE dim__print_unit ! print information on one dimension … … 518 526 !> @param[in] ld_uld dimension unlimited 519 527 !> @param[in] cd_sname dimension short name 520 !> @param[in] ld_u lddimension use or not528 !> @param[in] ld_use dimension use or not 521 529 !> @return dimension structure 522 530 !------------------------------------------------------------------- 523 TYPE(TDIM) FUNCTION dim_init( cd_name, id_len, ld_uld, cd_sname, ld_use )531 TYPE(TDIM) FUNCTION dim_init( cd_name, id_len, ld_uld, cd_sname, ld_use ) 524 532 IMPLICIT NONE 525 533 … … 1401 1409 1402 1410 END SUBROUTINE dim__clean_arr 1411 !------------------------------------------------------------------- 1412 !> @brief This subroutine fill dummy dimension array 1413 ! 1414 !> @author J.Paul 1415 !> @date September, 2015 - Initial Version 1416 ! 1417 !> @param[in] cd_dummy dummy configuration file 1418 !------------------------------------------------------------------- 1419 SUBROUTINE dim_get_dummy( cd_dummy ) 1420 IMPLICIT NONE 1421 ! Argument 1422 CHARACTER(LEN=*), INTENT(IN) :: cd_dummy 1423 1424 ! local variable 1425 INTEGER(i4) :: il_fileid 1426 INTEGER(i4) :: il_status 1427 1428 LOGICAL :: ll_exist 1429 1430 ! loop indices 1431 ! namelist 1432 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumvar 1433 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumdim 1434 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumatt 1435 1436 !---------------------------------------------------------------- 1437 NAMELIST /namdum/ & !< dummy namelist 1438 & cn_dumvar, & !< variable name 1439 & cn_dumdim, & !< dimension name 1440 & cn_dumatt !< attribute name 1441 !---------------------------------------------------------------- 1442 1443 ! init 1444 cm_dumdim(:)='' 1445 1446 ! read namelist 1447 INQUIRE(FILE=TRIM(cd_dummy), EXIST=ll_exist) 1448 IF( ll_exist )THEN 1449 1450 il_fileid=fct_getunit() 1451 1452 OPEN( il_fileid, FILE=TRIM(cd_dummy), & 1453 & FORM='FORMATTED', & 1454 & ACCESS='SEQUENTIAL', & 1455 & STATUS='OLD', & 1456 & ACTION='READ', & 1457 & IOSTAT=il_status) 1458 CALL fct_err(il_status) 1459 IF( il_status /= 0 )THEN 1460 CALL logger_fatal("DIM GET DUMMY: opening "//TRIM(cd_dummy)) 1461 ENDIF 1462 1463 READ( il_fileid, NML = namdum ) 1464 cm_dumdim(:)=cn_dumdim(:) 1465 1466 CLOSE( il_fileid ) 1467 1468 ENDIF 1469 1470 END SUBROUTINE dim_get_dummy 1471 !------------------------------------------------------------------- 1472 !> @brief This function check if dimension is defined as dummy dimension 1473 !> in configuraton file 1474 !> 1475 !> @author J.Paul 1476 !> @date September, 2015 - Initial Version 1477 ! 1478 !> @param[in] td_dim dimension structure 1479 !> @return true if dimension is dummy dimension 1480 !------------------------------------------------------------------- 1481 FUNCTION dim_is_dummy(td_dim) 1482 IMPLICIT NONE 1483 1484 ! Argument 1485 TYPE(TDIM), INTENT(IN) :: td_dim 1486 1487 ! function 1488 LOGICAL :: dim_is_dummy 1489 1490 ! loop indices 1491 INTEGER(i4) :: ji 1492 !---------------------------------------------------------------- 1493 1494 dim_is_dummy=.FALSE. 1495 DO ji=1,ip_maxdum 1496 IF( fct_lower(td_dim%c_name) == fct_lower(cm_dumdim(ji)) )THEN 1497 dim_is_dummy=.TRUE. 1498 EXIT 1499 ENDIF 1500 ENDDO 1501 1502 END FUNCTION dim_is_dummy 1403 1503 END MODULE dim 1404 1504 -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/docsrc/1_install.md
r5617 r7339 1 # How to Install1 # Download 2 2 3 # Install NEMO4 to install SIREN, you should first installNEMO.5 see [ here](http://www.nemo-ocean.eu/Using-NEMO/User-Guides/Basics/NEMO-Quick-Start-Guide)3 # Download NEMO # 4 to install SIREN, you should first download NEMO. 5 see [NEMO quick start guide](http://www.nemo-ocean.eu/Using-NEMO/User-Guides/Basics/NEMO-Quick-Start-Guide) 6 6 7 # Compile SIREN 7 # Compile SIREN # 8 8 when NEMO is installed, you just have to compile SIREN codes: 9 1. go to ./NEMOGCM/TOOLS 10 2. use maketools <br/> 11 to get help: maketools -h 9 1. go to ./NEMOGCM/TOOLS 10 2. run maketools (ex: ./maketools -n SIREN -m ifort_mpi_beaufix) 12 11 13 # Fortran Compiler 14 SIREN codes were succesfully tested with : 15 - ifort (version 15.0.1) 16 - gfortran (version 4.8.2 20140120) 17 <!-- - pgf95 (version 13.9-0) --> 12 @note to get help on maketools: ./maketools -h 18 13 19 <HR> 20 <b> 21 - @ref index 22 - @ref md_docsrc_3_codingRules 23 - @ref md_docsrc_4_changeLog 24 - @ref todo 25 </b> 14 # Fortran Compiler # 15 SIREN codes were succesfully tested with : 16 - ifort (version 15.0.1) 17 - gfortran (version 4.8.2 20140120) 18 19 <HR> 20 <b> 21 - @ref index 22 - @ref md_docsrc_2_quickstart 23 - @ref md_docsrc_3_support_bug 24 - @ref md_docsrc_4_codingRules 25 - @ref md_docsrc_5_changeLog 26 - @ref todo 27 </b> -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/docsrc/main.dox
r5037 r7339 1 1 /*! 2 @mainpage Main Page 3 @section descr Generic Description 4 SIREN is a software to create regional configuration with 5 [NEMO](http://www.nemo-ocean.eu).<br/> 2 @mainpage About 3 4 SIREN is a software to create regional configuration with [NEMO](http://www.nemo-ocean.eu).<br/> 6 5 Actually SIREN create input files needed for a basic NEMO configuration.<br/> 6 7 SIREN allows you to create your own regional configuration embedded in a wider one.<br/> 8 In order to help you, a set of GLORYS files (global reanalysis on ORCA025 grid), as well as examples 9 of namelists are available in dods repository. 10 11 @note This software was created, and is maintain by the Configuration Manager Working Group, composed 12 of NEMO system team members. 7 13 8 SIREN is composed of a set of 5 Fortran programs : 9 - create_coord.f90 to create fine grid coordinate file from coarse grid coordinate file. 10 - create_bathy.f90 to create fine grid bathymetry file over domain. 11 - merge_bathy.f90 to merge fine grid bathymetry with coarse grid bathymetry at boundaries. 12 - create_restart.f90 to create initial state file from coarse grid restart or standard outputs. 13 - create_boundary.f90 to create boundary condition from coarse grid standard outputs. 14 To know how to install SIREN see @ref md_docsrc_1_install. 14 15 15 To install those programs see @ref md_docsrc_1_install. 16 17 @note SIREN can not: 18 - create global configuration 19 - create configuarion around or close to north pole 20 - change number of vertical level 21 - change grid (horizontal or vertical) 22 23 @section howto How to use 24 @subsection howto_coord to create fine grid coordinate file 25 see create_coord.f90 26 @subsection howto_bathy to create fine grid bathymetry 27 see create_bathy.f90 28 @subsection howto_merge to merge fine grid bathymetry 29 see merge_bathy.f90 30 @subsection howto_restart to create initial state file 31 see create_restart.f90 32 @subsection howto_boundary to create boundary condition 33 see create_boundary.f90 16 You could find a tutorial for a quick start with SIREN in @ref md_docsrc_2_quickstart.<br/> 17 For more information about how to use each component of SIREN 18 - see create_coord.f90 to create fine grid coordinate file 19 - see create_bathy.f90 to create fine grid bathymetry 20 - see merge_bathy.f90 to merge fine grid bathymetry 21 - see create_restart.f90 to create initial state file, or other fields. 22 - see create_boundary.F90 to create boundary condition 34 23 35 24 <HR> 36 25 <b> 37 26 - @ref md_docsrc_1_install 38 - @ref md_docsrc_3_codingRules 39 - @ref md_docsrc_4_changeLog 27 - @ref md_docsrc_2_quickstart 28 - @ref md_docsrc_3_support_bug 29 - @ref md_docsrc_4_codingRules 30 - @ref md_docsrc_5_changeLog 40 31 - @ref todo 41 32 </b> -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/domain.f90
r5617 r7339 1297 1297 !> @date September, 2014 1298 1298 !> - take into account number of ghost cell 1299 !> @date February, 2016 1300 !> - number of extra point is the MAX (not the MIN) of zero and asess value. 1299 1301 ! 1300 1302 !> @param[inout] td_dom domain strcuture … … 1344 1346 td_dom%i_imin = td_dom%i_imin - td_dom%i_iextra(1) 1345 1347 ELSE ! td_dom%i_imin - il_iext <= td_dom%i_ghost0(jp_I,1)*ip_ghost 1346 td_dom%i_iextra(1) = M IN(0, &1348 td_dom%i_iextra(1) = MAX(0, & 1347 1349 & td_dom%i_imin - & 1348 1350 & td_dom%i_ghost0(jp_I,1)*ip_ghost -1) … … 1356 1358 ELSE ! td_dom%i_imax + il_iext >= & 1357 1359 ! td_dom%t_dim0(1)%i_len - td_dom%i_ghost0(jp_I,2)*ip_ghost 1358 td_dom%i_iextra(2) = M IN(0, &1360 td_dom%i_iextra(2) = MAX( 0, & 1359 1361 & td_dom%t_dim0(1)%i_len - & 1360 1362 & td_dom%i_ghost0(jp_I,2)*ip_ghost - & … … 1364 1366 1365 1367 ELSE ! td_dom%i_ew0 >= 0 1368 1366 1369 ! EW cyclic 1367 1370 IF( td_dom%i_imin - il_iext > 0 )THEN … … 1391 1394 ! nothing to be done 1392 1395 ELSE 1396 1393 1397 IF( td_dom%i_jmin - il_jext > td_dom%i_ghost0(jp_J,1)*ip_ghost )THEN 1394 1398 td_dom%i_jextra(1) = il_jext 1395 1399 td_dom%i_jmin = td_dom%i_jmin - td_dom%i_jextra(1) 1396 1400 ELSE ! td_dom%i_jmin - il_jext <= td_dom%i_ghost0(jp_J,1)*ip_ghost 1397 td_dom%i_jextra(1) = M IN(0, &1401 td_dom%i_jextra(1) = MAX( 0, & 1398 1402 & td_dom%i_jmin - & 1399 1403 & td_dom%i_ghost0(jp_J,1)*ip_ghost - 1) … … 1407 1411 ELSE ! td_dom%i_jmax + il_jext >= & 1408 1412 ! td_dom%t_dim0(2)%i_len - td_dom%i_ghost0(jp_J,2)*ip_ghost 1409 td_dom%i_jextra(2) = M IN(0, &1413 td_dom%i_jextra(2) = MAX( 0, & 1410 1414 & td_dom%t_dim0(2)%i_len - & 1411 1415 & td_dom%i_ghost0(jp_J,2)*ip_ghost - & -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/file.f90
r5617 r7339 694 694 !> @date November, 2013 - Initial Version 695 695 !> @date September, 2014 696 !> - add dimension tofile if need be696 !> - add dimension in file if need be 697 697 !> - do not reorder dimension from variable, before put in file 698 !> @date September, 2015 699 !> - check variable dimension expected 698 700 ! 699 701 !> @param[inout] td_file file structure … … 705 707 ! Argument 706 708 TYPE(TFILE), INTENT(INOUT) :: td_file 707 TYPE(TVAR) , INTENT(IN 709 TYPE(TVAR) , INTENT(INOUT) :: td_var 708 710 709 711 ! local variable … … 761 763 IF( file_check_var_dim(td_file, td_var) )THEN 762 764 765 ! check variable dimension expected 766 CALL var_check_dim(td_var) 767 763 768 ! update dimension if need be 764 769 DO ji=1,ip_maxdim … … 1050 1055 ! new number of variable in file 1051 1056 td_file%i_nvar=td_file%i_nvar-1 1052 1053 1057 SELECT CASE(td_var%i_ndim) 1054 1058 CASE(0) -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/function.f90
r5609 r7339 363 363 IF( id_status /= 0 )THEN 364 364 !CALL ERRSNS() ! not F95 standard 365 PRINT *, "FORTRAN ERROR "365 PRINT *, "FORTRAN ERROR ",id_status 366 366 !STOP 367 367 ENDIF … … 740 740 ! 741 741 !> @param[in] cd_var character 742 !> @return character is numeric742 !> @return character is real number 743 743 !------------------------------------------------------------------- 744 744 PURE LOGICAL FUNCTION fct_is_real(cd_var) -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/global.f90
r5037 r7339 12 12 ! REVISION HISTORY: 13 13 !> @date November, 2013 - Initial Version 14 !> @date September, 2015 15 !> - define fill value for each variable type 14 16 ! 15 17 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 95 97 & 'gauss '/) 96 98 97 REAL(dp) , PARAMETER :: dp_fill=NF90_FILL_DOUBLE !< default fill value 99 REAL(dp) , PARAMETER :: dp_fill_i1=NF90_FILL_BYTE !< byte fill value 100 REAL(dp) , PARAMETER :: dp_fill_i2=NF90_FILL_SHORT !< short fill value 101 REAL(dp) , PARAMETER :: dp_fill_i4=NF90_FILL_INT !< INT fill value 102 REAL(dp) , PARAMETER :: dp_fill_sp=NF90_FILL_FLOAT !< real fill value 103 REAL(dp) , PARAMETER :: dp_fill=NF90_FILL_DOUBLE !< double fill value 98 104 99 105 INTEGER(i4) , PARAMETER :: ip_npoint=4 … … 125 131 INTEGER(i4), PARAMETER :: jp_west =4 126 132 127 133 INTEGER(i4) , PARAMETER :: ip_maxdum = 10 !< maximum dummy variable, dimension, attribute 128 134 129 135 END MODULE global -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/grid.f90
r5617 r7339 80 80 !> point:<br/> 81 81 !> @code 82 !> il_index(:)=grid_get_closest(dd_lon0(:,:), dd_lat0(:,:), dd_lon1, dd_lat1) 82 !> il_index(:)=grid_get_closest(dd_lon0(:,:), dd_lat0(:,:), dd_lon1, dd_lat1 83 !> [,dd_fill] [,cd_pos]) 83 84 !> @endcode 84 85 !> - il_index(:) is coarse grid indices (/ i0, j0 /) … … 87 88 !> - dd_lon1 is fine grid longitude value (real(8)) 88 89 !> - dd_lat1 is fine grid latitude value (real(8)) 90 !> - dd_fill 91 !> - cd_pos 89 92 !> 90 93 !> to compute distance between a point A and grid points:<br/> … … 215 218 !> @date February, 2015 216 219 !> - add function grid_fill_small_msk to fill small domain inside bigger one 220 !> @February, 2016 221 !> - improve way to check coincidence (bug fix) 222 !> - manage grid cases for T,U,V or F point, with even or odd refinment (bug fix) 217 223 ! 218 224 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 664 670 665 671 ! no pivot point found 666 CALL logger_ error("GRID GET PIVOT: something wrong "//&672 CALL logger_warn("GRID GET PIVOT: something wrong "//& 667 673 & "when computing pivot point with variable "//& 668 674 & TRIM(td_var%c_name)) … … 685 691 686 692 IF( grid__get_pivot_var /= -1 )THEN 687 CALL logger_ warn("GRID GET PIVOT: variable "//&693 CALL logger_info("GRID GET PIVOT: variable "//& 688 694 & TRIM(td_var%c_name)//" seems to be on grid point "//& 689 695 & TRIM(cp_grid_point(jj)) ) … … 1335 1341 il_dim(:)=td_var%t_dim(:)%i_len 1336 1342 1337 CALL logger_ info("GRID GET PERIO: use varibale "//TRIM(td_var%c_name))1338 CALL logger_ info("GRID GET PERIO: fill value "//TRIM(fct_str(td_var%d_fill)))1339 CALL logger_ info("GRID GET PERIO: fillvalue "//TRIM(fct_str(td_var%d_value(1,1,1,1))))1343 CALL logger_debug("GRID GET PERIO: use varibale "//TRIM(td_var%c_name)) 1344 CALL logger_debug("GRID GET PERIO: fill value "//TRIM(fct_str(td_var%d_fill))) 1345 CALL logger_debug("GRID GET PERIO: first value "//TRIM(fct_str(td_var%d_value(1,1,1,1)))) 1340 1346 1341 1347 IF(ALL(td_var%d_value( 1 , : ,1,1)/=td_var%d_fill).AND.& … … 1344 1350 & ALL(td_var%d_value( : ,il_dim(2),1,1)/=td_var%d_fill))THEN 1345 1351 ! no boundary closed 1346 CALL logger_ warn("GRID GET PERIO: can't determined periodicity. "//&1352 CALL logger_error("GRID GET PERIO: can't determined periodicity. "//& 1347 1353 & "there is no boundary closed for variable "//& 1348 1354 & TRIM(td_var%c_name) ) 1355 ! check pivot 1356 SELECT CASE(id_pivot) 1357 CASE(0) 1358 ! F pivot 1359 CALL logger_warn("GRID GET PERIO: assume domain is global") 1360 grid__get_perio_var=6 1361 CASE(1) 1362 ! T pivot 1363 CALL logger_warn("GRID GET PERIO: assume domain is global") 1364 grid__get_perio_var=4 1365 END SELECT 1349 1366 ELSE 1350 1367 ! check periodicity … … 2287 2304 & il_rho(:), cl_point ) 2288 2305 2289 2290 2306 CALL var_clean(tl_lon1) 2291 2307 CALL var_clean(tl_lat1) … … 2463 2479 !> - check grid point 2464 2480 !> - take into account EW overlap 2481 !> @date February, 2016 2482 !> - use delta (lon or lat) 2483 !> - manage cases for T,U,V or F point, with even or odd refinment 2465 2484 !> 2466 2485 !> @param[in] td_lon0 coarse grid longitude … … 2490 2509 2491 2510 ! local variable 2492 REAL(dp) :: dl_lon1_ll 2493 REAL(dp) :: dl_lon1_ul 2494 REAL(dp) :: dl_lon1_lr 2495 REAL(dp) :: dl_lon1_ur 2496 2497 REAL(dp) :: dl_lat1_ll 2498 REAL(dp) :: dl_lat1_ul 2499 REAL(dp) :: dl_lat1_lr 2500 REAL(dp) :: dl_lat1_ur 2511 CHARACTER(LEN= 1) :: cl_point0 2512 CHARACTER(LEN= 1) :: cl_point1 2513 2514 LOGICAL , DIMENSION(2) :: ll_even 2515 2516 REAL(dp) :: dl_lon1 2517 REAL(dp) :: dl_dlon 2518 REAL(dp) :: dl_lat1 2519 REAL(dp) :: dl_dlat 2520 2521 INTEGER(i4) :: il_ew0 2522 INTEGER(i4) :: il_imin0 2523 INTEGER(i4) :: il_imax0 2524 INTEGER(i4) :: il_jmin0 2525 INTEGER(i4) :: il_jmax0 2526 2527 INTEGER(i4) :: il_ew1 2528 INTEGER(i4) :: il_imin1 2529 INTEGER(i4) :: il_imax1 2530 INTEGER(i4) :: il_jmin1 2531 INTEGER(i4) :: il_jmax1 2532 2533 INTEGER(i4) :: il_imin 2534 INTEGER(i4) :: il_imax 2535 INTEGER(i4) :: il_jmin 2536 INTEGER(i4) :: il_jmax 2501 2537 2502 2538 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho 2503 2539 2504 INTEGER(i4), DIMENSION(2) :: il_ill 2505 INTEGER(i4), DIMENSION(2) :: il_ilr 2506 INTEGER(i4), DIMENSION(2) :: il_iul 2507 INTEGER(i4), DIMENSION(2) :: il_iur 2508 2509 INTEGER(i4) :: il_ew0 2510 INTEGER(i4) :: il_imin0 2511 INTEGER(i4) :: il_imax0 2512 INTEGER(i4) :: il_jmin0 2513 INTEGER(i4) :: il_jmax0 2514 2515 INTEGER(i4) :: il_ew1 2516 INTEGER(i4) :: il_imin1 2517 INTEGER(i4) :: il_imax1 2518 INTEGER(i4) :: il_jmin1 2519 INTEGER(i4) :: il_jmax1 2520 2521 INTEGER(i4) :: il_imin 2522 INTEGER(i4) :: il_imax 2523 INTEGER(i4) :: il_jmin 2524 INTEGER(i4) :: il_jmax 2525 2526 INTEGER(i4), DIMENSION(2,2) :: il_xghost0 2527 INTEGER(i4), DIMENSION(2,2) :: il_yghost0 2528 INTEGER(i4), DIMENSION(2,2) :: il_xghost1 2529 INTEGER(i4), DIMENSION(2,2) :: il_yghost1 2530 2531 TYPE(TVAR) :: tl_lon0 2532 TYPE(TVAR) :: tl_lat0 2533 TYPE(TVAR) :: tl_lon1 2534 TYPE(TVAR) :: tl_lat1 2535 2536 CHARACTER(LEN= 1) :: cl_point0 2537 CHARACTER(LEN= 1) :: cl_point1 2538 2540 INTEGER(i4), DIMENSION(2) :: il_ill 2541 INTEGER(i4), DIMENSION(2) :: il_ilr 2542 INTEGER(i4), DIMENSION(2) :: il_iul 2543 INTEGER(i4), DIMENSION(2) :: il_iur 2544 2545 INTEGER(i4), DIMENSION(2,2) :: il_xghost0 2546 INTEGER(i4), DIMENSION(2,2) :: il_yghost0 2547 INTEGER(i4), DIMENSION(2,2) :: il_xghost1 2548 INTEGER(i4), DIMENSION(2,2) :: il_yghost1 2549 2550 TYPE(TVAR) :: tl_lon0 2551 TYPE(TVAR) :: tl_lat0 2552 TYPE(TVAR) :: tl_lon1 2553 TYPE(TVAR) :: tl_lat1 2554 2539 2555 ! loop indices 2540 INTEGER(i4) :: ji2541 INTEGER(i4) :: jj2542 2556 !---------------------------------------------------------------- 2543 2557 ! init … … 2547 2561 il_rho(:)=1 2548 2562 IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:) 2563 2564 ll_even(:)=(/ (MOD(id_rho(jp_I),2)==0), (MOD(id_rho(jp_J),2)==0) /) 2549 2565 2550 2566 cl_point0='T' … … 2645 2661 ! get indices for each corner 2646 2662 !1- search lower left corner indices 2647 dl_lon1_ll=tl_lon1%d_value( il_imin1, il_jmin1, 1, 1 ) 2648 dl_lat1_ll=tl_lat1%d_value( il_imin1, il_jmin1, 1, 1 ) 2649 2650 IF( dl_lon1_ll == tl_lon1%d_fill .OR. & 2651 & dl_lat1_ll == tl_lat1%d_fill )THEN 2652 CALL logger_debug("GRID GET COARSE INDEX: lon "//& 2653 & TRIM(fct_str(dl_lon1_ll))//" "//& 2654 & TRIM(fct_str(tl_lon1%d_fill)) ) 2655 CALL logger_debug("GRID GET COARSE INDEX: lat "//& 2656 & TRIM(fct_str(dl_lat1_ll))//" "//& 2657 & TRIM(fct_str(tl_lat1%d_fill)) ) 2663 dl_lon1=tl_lon1%d_value( il_imin1, il_jmin1, 1, 1 ) 2664 dl_lat1=tl_lat1%d_value( il_imin1, il_jmin1, 1, 1 ) 2665 2666 IF( dl_lon1 == tl_lon1%d_fill .OR. & 2667 & dl_lat1 == tl_lat1%d_fill )THEN 2658 2668 CALL logger_error("GRID GET COARSE INDEX: lower left corner "//& 2659 2669 & "point is FillValue. remove ghost cell "//& 2660 2670 & "before running grid_get_coarse_index.") 2661 2671 ENDIF 2672 2673 !!!!! i-direction !!!!! 2674 IF( ll_even(jp_I) )THEN 2675 ! even 2676 SELECT CASE(TRIM(cl_point1)) 2677 CASE('F','U') 2678 dl_dlon= ( tl_lon1%d_value(il_imin1+1,il_jmin1,1,1) - & 2679 & tl_lon1%d_value(il_imin1 ,il_jmin1,1,1) ) / & 2680 & 2. 2681 CASE DEFAULT 2682 dl_dlon=0 2683 END SELECT 2684 ELSE 2685 ! odd 2686 dl_dlon= ( tl_lon1%d_value(il_imin1+1,il_jmin1,1,1) - & 2687 & tl_lon1%d_value(il_imin1 ,il_jmin1,1,1) ) / & 2688 & 2. 2689 ENDIF 2690 2691 !!!!! j-direction !!!!! 2692 IF( ll_even(jp_J) )THEN 2693 ! even 2694 SELECT CASE(TRIM(cl_point1)) 2695 CASE('F','V') 2696 dl_dlat= ( tl_lat1%d_value(il_imin1,il_jmin1+1,1,1) - & 2697 & tl_lat1%d_value(il_imin1,il_jmin1 ,1,1) ) / & 2698 & 2. 2699 CASE DEFAULT 2700 dl_dlat=0 2701 END SELECT 2702 ELSE 2703 ! odd 2704 dl_dlat= ( tl_lat1%d_value(il_imin1,il_jmin1+1,1,1) - & 2705 & tl_lat1%d_value(il_imin1,il_jmin1 ,1,1) ) / & 2706 & 2. 2707 ENDIF 2708 2709 dl_lon1 = dl_lon1 + dl_dlon 2710 dl_lat1 = dl_lat1 + dl_dlat 2711 2662 2712 ! look for closest point on coarse grid 2663 2713 il_ill(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, & … … 2667 2717 & il_jmin0:il_jmax0, & 2668 2718 & 1,1), & 2669 & dl_lon1_ll, dl_lat1_ll ) 2670 2671 ! coarse grid point should be south west of fine grid domain 2672 ji = il_ill(1) 2673 jj = il_ill(2) 2674 2675 IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_ll) > dp_delta )THEN 2676 IF(tl_lon0%d_value(ji,jj,1,1) > dl_lon1_ll )THEN 2677 il_ill(1)=il_ill(1)-1 2678 IF( il_ill(1) <= 0 )THEN 2679 IF( tl_lon0%i_ew >= 0 )THEN 2680 il_ill(1)=tl_lon0%t_dim(jp_I)%i_len-tl_lon0%i_ew 2681 ELSE 2682 CALL logger_error("GRID GET COARSE INDEX: error "//& 2683 & "computing lower left corner "//& 2684 & "index for longitude") 2685 ENDIF 2686 ENDIF 2687 ENDIF 2688 ENDIF 2689 IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_ll) > dp_delta )THEN 2690 IF(tl_lat0%d_value(ji,jj,1,1) > dl_lat1_ll )THEN 2691 il_ill(2)=il_ill(2)-1 2692 IF( il_ill(2)-1 <= 0 )THEN 2693 CALL logger_error("GRID GET COARSE INDEX: error "//& 2694 & "computing lower left corner "//& 2695 & "index for latitude") 2696 ENDIF 2697 ENDIF 2698 ENDIF 2719 & dl_lon1, dl_lat1, 'll' ) 2720 2699 2721 2700 2722 !2- search upper left corner indices 2701 dl_lon1 _ul=tl_lon1%d_value( il_imin1, il_jmax1, 1, 1 )2702 dl_lat1 _ul=tl_lat1%d_value( il_imin1, il_jmax1, 1, 1 )2703 2704 IF( dl_lon1 _ul== tl_lon1%d_fill .OR. &2705 & dl_lat1 _ul== tl_lat1%d_fill )THEN2723 dl_lon1=tl_lon1%d_value( il_imin1, il_jmax1, 1, 1 ) 2724 dl_lat1=tl_lat1%d_value( il_imin1, il_jmax1, 1, 1 ) 2725 2726 IF( dl_lon1 == tl_lon1%d_fill .OR. & 2727 & dl_lat1 == tl_lat1%d_fill )THEN 2706 2728 CALL logger_error("GRID GET COARSE INDEX: upper left corner "//& 2707 2729 & "point is FillValue. remove ghost cell "//& 2708 2730 & "running grid_get_coarse_index.") 2709 2731 ENDIF 2732 2733 !!!!! i-direction !!!!! 2734 IF( ll_even(jp_I) )THEN 2735 ! even 2736 SELECT CASE(TRIM(cl_point1)) 2737 CASE('F','U') 2738 dl_dlon= ( tl_lon1%d_value(il_imin1+1,il_jmax1,1,1) - & 2739 & tl_lon1%d_value(il_imin1 ,il_jmax1,1,1) ) / & 2740 & 2. 2741 CASE DEFAULT 2742 dl_dlon=0 2743 END SELECT 2744 ELSE 2745 ! odd 2746 dl_dlon= ( tl_lon1%d_value(il_imin1+1,il_jmax1,1,1) - & 2747 & tl_lon1%d_value(il_imin1 ,il_jmax1,1,1) ) / & 2748 & 2. 2749 ENDIF 2750 2751 !!!!! j-direction !!!!! 2752 IF( ll_even(jp_J) )THEN 2753 ! even 2754 SELECT CASE(TRIM(cl_point1)) 2755 CASE('F','V') 2756 dl_dlat= ( tl_lat1%d_value(il_imin1,il_jmax1 ,1,1) - & 2757 & tl_lat1%d_value(il_imin1,il_jmax1-1,1,1) ) / & 2758 & 2. 2759 CASE DEFAULT 2760 dl_dlat=0 2761 END SELECT 2762 ELSE 2763 ! odd 2764 dl_dlat= ( tl_lat1%d_value(il_imin1,il_jmax1 ,1,1) - & 2765 & tl_lat1%d_value(il_imin1,il_jmax1-1,1,1) ) / & 2766 & 2. 2767 ENDIF 2768 2769 dl_lon1 = dl_lon1 + dl_dlon 2770 dl_lat1 = dl_lat1 - dl_dlat 2771 2710 2772 ! look for closest point on coarse grid 2711 2773 il_iul(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, & … … 2715 2777 & il_jmin0:il_jmax0, & 2716 2778 & 1,1), & 2717 & dl_lon1_ul, dl_lat1_ul ) 2718 2719 ! coarse grid point should be north west of fine grid domain 2720 ji = il_iul(1) 2721 jj = il_iul(2) 2722 IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_ul) > dp_delta )THEN 2723 IF(tl_lon0%d_value(ji,jj,1,1) > dl_lon1_ul )THEN 2724 il_iul(1)=il_iul(1)-1 2725 IF( il_iul(1) <= 0 )THEN 2726 IF( tl_lon0%i_ew >= 0 )THEN 2727 il_iul(1)=tl_lon0%t_dim(jp_I)%i_len-tl_lon0%i_ew 2728 ELSE 2729 CALL logger_error("GRID GET COARSE INDEX: error "//& 2730 & "computing upper left corner "//& 2731 & "index for longitude") 2732 ENDIF 2733 ENDIF 2734 ENDIF 2735 ENDIF 2736 IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_ul) > dp_delta )THEN 2737 IF(tl_lat0%d_value(ji,jj,1,1) < dl_lat1_ul )THEN 2738 il_iul(2)=il_iul(2)+1 2739 IF( il_ill(2) > tl_lat0%t_dim(jp_J)%i_len )THEN 2740 CALL logger_error("GRID GET COARSE INDEX: error "//& 2741 & "computing upper left corner "//& 2742 & "index for latitude") 2743 ENDIF 2744 ENDIF 2745 ENDIF 2779 & dl_lon1, dl_lat1, 'ul' ) 2746 2780 2747 2781 !3- search lower right corner indices 2748 dl_lon1 _lr=tl_lon1%d_value( il_imax1, il_jmin1, 1, 1 )2749 dl_lat1 _lr=tl_lat1%d_value( il_imax1, il_jmin1, 1, 1 )2750 2751 IF( dl_lon1 _lr== tl_lon1%d_fill .OR. &2752 & dl_lat1 _lr== tl_lat1%d_fill )THEN2782 dl_lon1=tl_lon1%d_value( il_imax1, il_jmin1, 1, 1 ) 2783 dl_lat1=tl_lat1%d_value( il_imax1, il_jmin1, 1, 1 ) 2784 2785 IF( dl_lon1 == tl_lon1%d_fill .OR. & 2786 & dl_lat1 == tl_lat1%d_fill )THEN 2753 2787 CALL logger_error("GRID GET COARSE INDEX: lower right corner "//& 2754 2788 & "point is FillValue. remove ghost cell "//& 2755 2789 & "running grid_get_coarse_index.") 2756 2790 ENDIF 2791 2792 !!!!! i-direction !!!!! 2793 IF( ll_even(jp_I) )THEN 2794 ! even 2795 SELECT CASE(TRIM(cl_point1)) 2796 CASE('F','U') 2797 dl_dlon= ( tl_lon1%d_value(il_imax1 ,il_jmin1,1,1) - & 2798 & tl_lon1%d_value(il_imax1-1,il_jmin1,1,1) ) / & 2799 & 2. 2800 CASE DEFAULT 2801 dl_dlon=0 2802 END SELECT 2803 ELSE 2804 ! odd 2805 dl_dlon= ( tl_lon1%d_value(il_imax1 ,il_jmin1,1,1) - & 2806 & tl_lon1%d_value(il_imax1-1,il_jmin1,1,1) ) / & 2807 & 2. 2808 ENDIF 2809 2810 !!!!! j-direction !!!!! 2811 IF( ll_even(jp_J) )THEN 2812 ! even 2813 SELECT CASE(TRIM(cl_point1)) 2814 CASE('F','V') 2815 dl_dlat= ( tl_lat1%d_value(il_imax1,il_jmin1+1,1,1) - & 2816 & tl_lat1%d_value(il_imax1,il_jmin1 ,1,1) ) / & 2817 & 2. 2818 CASE DEFAULT 2819 dl_dlat=0 2820 END SELECT 2821 ELSE 2822 ! odd 2823 dl_dlat= ( tl_lat1%d_value(il_imax1,il_jmin1+1,1,1) - & 2824 & tl_lat1%d_value(il_imax1,il_jmin1 ,1,1) ) / & 2825 & 2. 2826 ENDIF 2827 2828 dl_lon1 = dl_lon1 - dl_dlon 2829 dl_lat1 = dl_lat1 + dl_dlat 2830 2757 2831 ! look for closest point on coarse grid 2758 2832 il_ilr(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, & … … 2762 2836 & il_jmin0:il_jmax0, & 2763 2837 & 1,1), & 2764 & dl_lon1_lr, dl_lat1_lr ) 2765 2766 ! coarse grid point should be south east of fine grid domain 2767 ji = il_ilr(1) 2768 jj = il_ilr(2) 2769 IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_lr) > dp_delta )THEN 2770 IF( tl_lon0%d_value(ji,jj,1,1) < dl_lon1_lr )THEN 2771 il_ilr(1)=il_ilr(1)+1 2772 IF( il_ilr(1) > tl_lon0%t_dim(jp_I)%i_len )THEN 2773 IF( tl_lon0%i_ew >= 0 )THEN 2774 il_ilr(1)=tl_lon0%i_ew+1 2775 ELSE 2776 CALL logger_error("GRID GET COARSE INDEX: error "//& 2777 & "computing lower right corner "//& 2778 & "index for longitude") 2779 ENDIF 2780 ENDIF 2781 ENDIF 2782 ENDIF 2783 IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_lr) > dp_delta )THEN 2784 IF( tl_lat0%d_value(ji,jj,1,1) > dl_lat1_lr )THEN 2785 il_ilr(2)=il_ilr(2)-1 2786 IF( il_ilr(2) <= 0 )THEN 2787 CALL logger_error("GRID GET COARSE INDEX: error "//& 2788 & "computing lower right corner "//& 2789 & "index for latitude") 2790 ENDIF 2791 ENDIF 2792 ENDIF 2838 & dl_lon1, dl_lat1, 'lr' ) 2793 2839 2794 2840 !4- search upper right corner indices 2795 dl_lon1 _ur=tl_lon1%d_value( il_imax1, il_jmax1, 1, 1 )2796 dl_lat1 _ur=tl_lat1%d_value( il_imax1, il_jmax1, 1, 1 )2797 2798 IF( dl_lon1 _ur== tl_lon1%d_fill .OR. &2799 & dl_lat1 _ur== tl_lat1%d_fill )THEN2841 dl_lon1=tl_lon1%d_value( il_imax1, il_jmax1, 1, 1 ) 2842 dl_lat1=tl_lat1%d_value( il_imax1, il_jmax1, 1, 1 ) 2843 2844 IF( dl_lon1 == tl_lon1%d_fill .OR. & 2845 & dl_lat1 == tl_lat1%d_fill )THEN 2800 2846 CALL logger_error("GRID GET COARSE INDEX: upper right corner "//& 2801 2847 & "point is FillValue. remove ghost cell "//& 2802 & " running grid_get_coarse_index.")2848 & "before running grid_get_coarse_index.") 2803 2849 ENDIF 2850 2851 !!!!! i-direction !!!!! 2852 IF( ll_even(jp_I) )THEN 2853 ! even 2854 SELECT CASE(TRIM(cl_point1)) 2855 CASE('F','U') 2856 dl_dlon= ( tl_lon1%d_value(il_imax1 ,il_jmax1,1,1) - & 2857 & tl_lon1%d_value(il_imax1-1,il_jmax1,1,1) ) / & 2858 & 2. 2859 CASE DEFAULT 2860 dl_dlon=0 2861 END SELECT 2862 ELSE 2863 ! odd 2864 dl_dlon= ( tl_lon1%d_value(il_imax1 ,il_jmax1,1,1) - & 2865 & tl_lon1%d_value(il_imax1-1,il_jmax1,1,1) ) / & 2866 & 2. 2867 ENDIF 2868 2869 !!!!! j-direction !!!!! 2870 IF( ll_even(jp_J) )THEN 2871 ! even 2872 SELECT CASE(TRIM(cl_point1)) 2873 CASE('F','V') 2874 dl_dlat= ( tl_lat1%d_value(il_imax1,il_jmax1 ,1,1) - & 2875 & tl_lat1%d_value(il_imax1,il_jmax1-1,1,1) ) / & 2876 & 2. 2877 CASE DEFAULT 2878 dl_dlat=0 2879 END SELECT 2880 ELSE 2881 ! odd 2882 dl_dlat= ( tl_lat1%d_value(il_imax1,il_jmax1 ,1,1) - & 2883 & tl_lat1%d_value(il_imax1,il_jmax1-1,1,1) ) / & 2884 & 2. 2885 ENDIF 2886 2887 dl_lon1 = dl_lon1 - dl_dlon 2888 dl_lat1 = dl_lat1 - dl_dlat 2889 2804 2890 ! look for closest point on coarse grid 2805 2891 il_iur(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, & … … 2809 2895 & il_jmin0:il_jmax0, & 2810 2896 & 1,1), & 2811 & dl_lon1_ur, dl_lat1_ur ) 2812 2813 ! coarse grid point should be north east fine grid domain 2814 ji = il_iur(1) 2815 jj = il_iur(2) 2816 IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_ur) > dp_delta )THEN 2817 IF( tl_lon0%d_value(ji,jj,1,1) < dl_lon1_ur )THEN 2818 il_iur(1)=il_iur(1)+1 2819 IF( il_iur(1) > tl_lon0%t_dim(jp_I)%i_len )THEN 2820 IF( tl_lon0%i_ew >= 0 )THEN 2821 il_iur(1)=tl_lon0%i_ew+1 2822 ELSE 2823 CALL logger_error("GRID GET COARSE INDEX: error "//& 2824 & "computing upper right corner "//& 2825 & "index for longitude") 2826 ENDIF 2827 ENDIF 2828 ENDIF 2829 ENDIF 2830 IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_ur) > dp_delta )THEN 2831 IF( tl_lat0%d_value(ji,jj,1,1) < dl_lat1_ur )THEN 2832 il_iur(2)=il_iur(2)+1 2833 IF( il_iur(2) > tl_lat0%t_dim(jp_J)%i_len )THEN 2834 CALL logger_error("GRID GET COARSE INDEX: error "//& 2835 & "computing upper right corner "//& 2836 & "index for latitude") 2837 ENDIF 2838 ENDIF 2839 ENDIF 2897 & dl_lon1, dl_lat1, 'ur' ) 2840 2898 2841 2899 ! coarse grid indices … … 2943 3001 END FUNCTION grid_is_global 2944 3002 !------------------------------------------------------------------- 2945 !> @brief This function return coarsegrid indices of the closest point2946 !> from fine gridpoint (lon1,lat1)3003 !> @brief This function return grid indices of the closest point 3004 !> from point (lon1,lat1) 2947 3005 !> 2948 3006 !> @details … … 2951 3009 !> of longitude and latitude, before running this function 2952 3010 !> 3011 !> if you add cd_pos argument, you could choice to return closest point at 3012 !> - lower left (ll) of the point 3013 !> - lower right (lr) of the point 3014 !> - upper left (ul) of the point 3015 !> - upper right (ur) of the point 3016 !> - lower (lo) of the point 3017 !> - upper (up) of the point 3018 !> - left (le) of the point 3019 !> - right (ri) of the point 3020 !> 2953 3021 !> @author J.Paul 2954 3022 !> @date November, 2013 - Initial Version 2955 !> @date February, 2015 - change dichotomy method to manage ORCA grid 3023 !> @date February, 2015 3024 !> - change dichotomy method to manage ORCA grid 3025 !> @date February, 2016 3026 !> - add optional use of relative position 2956 3027 ! 2957 3028 !> @param[in] dd_lon0 coarse grid array of longitude … … 2959 3030 !> @param[in] dd_lon1 fine grid longitude 2960 3031 !> @param[in] dd_lat1 fine grid latitude 3032 !> @param[in] cd_pos relative position of grid point from point 2961 3033 !> @param[in] dd_fill fill value 2962 3034 !> @return coarse grid indices of closest point of fine grid point 2963 3035 !------------------------------------------------------------------- 2964 FUNCTION grid_get_closest( dd_lon0, dd_lat0, dd_lon1, dd_lat1, dd_fill )3036 FUNCTION grid_get_closest( dd_lon0, dd_lat0, dd_lon1, dd_lat1, cd_pos, dd_fill ) 2965 3037 IMPLICIT NONE 2966 3038 ! Argument … … 2969 3041 REAL(dp), INTENT(IN) :: dd_lon1 2970 3042 REAL(dp), INTENT(IN) :: dd_lat1 3043 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_pos 2971 3044 REAL(dp), INTENT(IN), OPTIONAL :: dd_fill 2972 3045 … … 3147 3220 & dl_lon1, dd_lat1 ) 3148 3221 3222 IF( PRESENT(cd_pos) )THEN 3223 ! 3224 SELECT CASE(TRIM(cd_pos)) 3225 CASE('le') 3226 WHERE( dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) > dd_lat1 ) 3227 dl_dist(:,:)=NF90_FILL_DOUBLE 3228 END WHERE 3229 CASE('ri') 3230 WHERE( dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) < dd_lat1 ) 3231 dl_dist(:,:)=NF90_FILL_DOUBLE 3232 END WHERE 3233 CASE('up') 3234 WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) < dl_lon1 ) 3235 dl_dist(:,:)=NF90_FILL_DOUBLE 3236 END WHERE 3237 CASE('lo') 3238 WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) > dl_lon1 ) 3239 dl_dist(:,:)=NF90_FILL_DOUBLE 3240 END WHERE 3241 CASE('ll') 3242 WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) > dl_lon1 .OR. & 3243 & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) > dd_lat1 ) 3244 dl_dist(:,:)=NF90_FILL_DOUBLE 3245 END WHERE 3246 CASE('lr') 3247 WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) < dl_lon1 .OR. & 3248 & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) > dd_lat1 ) 3249 dl_dist(:,:)=NF90_FILL_DOUBLE 3250 END WHERE 3251 CASE('ul') 3252 WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) > dl_lon1 .OR. & 3253 & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) < dd_lat1 ) 3254 dl_dist(:,:)=NF90_FILL_DOUBLE 3255 END WHERE 3256 CASE('ur') 3257 WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) < dl_lon1 .OR. & 3258 & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) < dd_lat1 ) 3259 dl_dist(:,:)=NF90_FILL_DOUBLE 3260 END WHERE 3261 END SELECT 3262 ENDIF 3149 3263 grid_get_closest(:)=MINLOC(dl_dist(:,:),dl_dist(:,:)/=NF90_FILL_DOUBLE) 3150 3264 … … 3443 3557 & il_imax0, il_jmax0, & 3444 3558 & dl_lon1(:,:), dl_lat1(:,:),& 3445 & id_rho(:) )3559 & id_rho(:), cl_point ) 3446 3560 3447 3561 DEALLOCATE(dl_lon0, dl_lat0) … … 3588 3702 & id_imax0, id_jmax0, & 3589 3703 & dl_lon1(:,:), dl_lat1(:,:),& 3590 & id_rho(:) )3704 & id_rho(:), cl_point ) 3591 3705 3592 3706 DEALLOCATE(dl_lon1, dl_lat1) … … 3668 3782 ! init 3669 3783 grid__get_fine_offset_fc(:,:)=-1 3670 3671 3784 ALLOCATE(il_rho(ip_maxdim)) 3672 3785 il_rho(:)=1 … … 3690 3803 CALL iom_mpp_open(tl_coord0) 3691 3804 3692 ! read coarse longitu e and latitude3805 ! read coarse longitude and latitude 3693 3806 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 3694 3807 il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) … … 3710 3823 ENDIF 3711 3824 tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) 3712 3825 3713 3826 ! close mpp files 3714 3827 CALL iom_mpp_close(tl_coord0) … … 3716 3829 CALL grid_del_ghost(tl_lon0, il_xghost0(:,:)) 3717 3830 CALL grid_del_ghost(tl_lat0, il_xghost0(:,:)) 3831 3718 3832 3719 3833 ALLOCATE(dl_lon0(tl_lon0%t_dim(jp_I)%i_len, & … … 3738 3852 il_jmax0=id_jmax0-il_xghost0(jp_J,1) 3739 3853 3740 3741 3854 !3- compute 3742 3855 grid__get_fine_offset_fc(:,:)=grid_get_fine_offset(& … … 3745 3858 & il_imax0, il_jmax0, & 3746 3859 & dd_lon1(:,:), dd_lat1(:,:),& 3747 & id_rho(:) )3860 & id_rho(:), cl_point ) 3748 3861 3749 3862 DEALLOCATE(dl_lon0, dl_lat0) … … 3767 3880 !> @date May, 2015 3768 3881 !> - improve way to find offset 3882 !> @date July, 2015 3883 !> - manage case close to greenwich meridian 3884 !> @date February, 2016 3885 !> - use grid_get_closest to assess offset 3886 !> - use delta (lon or lat) 3887 !> - manage cases for T,U,V or F point, with even or odd refinment 3888 !> - check lower left(upper right) fine grid point inside lower left(upper 3889 !> right) coarse grid cell. 3890 !> 3891 !> @todo check case close from North fold. 3769 3892 !> 3770 3893 !> @param[in] dd_lon0 coarse grid longitude array … … 3777 3900 !> @param[in] dd_lat1 fine grid latitude array 3778 3901 !> @param[in] id_rho array of refinement factor 3902 !> @param[in] cd_point Arakawa grid point 3779 3903 !> @return offset array (/ (/i_offset_left,i_offset_right/),(/j_offset_lower,j_offset_upper/) /) 3780 3904 !------------------------------------------------------------------- 3781 3905 FUNCTION grid__get_fine_offset_cc( dd_lon0, dd_lat0, & 3782 3906 & id_imin0, id_jmin0, id_imax0, id_jmax0, & 3783 & dd_lon1, dd_lat1, id_rho )3907 & dd_lon1, dd_lat1, id_rho, cd_point ) 3784 3908 IMPLICIT NONE 3785 3909 ! Argument 3786 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon0 3787 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat0 3788 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon1 3789 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat1 3790 3791 INTEGER(i4), INTENT(IN) :: id_imin0 3792 INTEGER(i4), INTENT(IN) :: id_jmin0 3793 INTEGER(i4), INTENT(IN) :: id_imax0 3794 INTEGER(i4), INTENT(IN) :: id_jmax0 3795 3796 INTEGER(i4), DIMENSION(:) , INTENT(IN) :: id_rho 3910 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon0 3911 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat0 3912 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon1 3913 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat1 3914 3915 INTEGER(i4) , INTENT(IN) :: id_imin0 3916 INTEGER(i4) , INTENT(IN) :: id_jmin0 3917 INTEGER(i4) , INTENT(IN) :: id_imax0 3918 INTEGER(i4) , INTENT(IN) :: id_jmax0 3919 3920 INTEGER(i4) , DIMENSION(:) , INTENT(IN) :: id_rho 3921 CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point 3797 3922 3798 3923 ! function … … 3800 3925 3801 3926 ! local variable 3927 CHARACTER(LEN= 1) :: cl_point 3928 3929 INTEGER(i4) :: i1 3930 INTEGER(i4) :: i2 3931 INTEGER(i4) :: j1 3932 INTEGER(i4) :: j2 3933 3802 3934 INTEGER(i4), DIMENSION(2) :: il_shape0 3803 3935 INTEGER(i4), DIMENSION(2) :: il_shape1 3804 3936 3937 INTEGER(i4), DIMENSION(2) :: il_ind 3938 3805 3939 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon0 3806 3940 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon1 3807 3941 3808 LOGICAL :: ll_ii 3809 LOGICAL :: ll_ij 3942 REAL(dp) :: dl_lonmax0 3943 REAL(dp) :: dl_latmax0 3944 REAL(dp) :: dl_lonmin0 3945 REAL(dp) :: dl_latmin0 3946 3947 REAL(dp) :: dl_lon0F 3948 REAL(dp) :: dl_lat0F 3949 REAL(dp) :: dl_dlon 3950 REAL(dp) :: dl_dlat 3951 3952 LOGICAL , DIMENSION(2) :: ll_even 3953 LOGICAL :: ll_greenwich 3810 3954 3811 3955 ! loop indices 3812 INTEGER(i4) :: ji3813 INTEGER(i4) :: jj3814 3815 3956 INTEGER(i4) :: ii 3816 3957 INTEGER(i4) :: ij … … 3824 3965 CALL logger_fatal("GRID GET FINE OFFSET: dimension of fine "//& 3825 3966 & "longitude and latitude differ") 3826 ENDIF 3967 ENDIF 3968 3969 ll_even(:)=(/ (MOD(id_rho(jp_I),2)==0), (MOD(id_rho(jp_J),2)==0) /) 3970 3971 cl_point='T' 3972 IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point)) 3827 3973 3828 3974 il_shape0(:)=SHAPE(dd_lon0(:,:)) 3829 3975 ALLOCATE( dl_lon0(il_shape0(1),il_shape0(2)) ) 3830 3976 3977 il_shape1(:)=SHAPE(dd_lon1(:,:)) 3978 ALLOCATE( dl_lon1(il_shape1(1),il_shape1(2)) ) 3979 3831 3980 dl_lon0(:,:)=dd_lon0(:,:) 3832 3981 WHERE( dd_lon0(:,:) < 0 ) dl_lon0(:,:)=dd_lon0(:,:)+360. 3833 3982 3834 il_shape1(:)=SHAPE(dd_lon1(:,:))3835 ALLOCATE( dl_lon1(il_shape1(1),il_shape1(2)) )3836 3837 3983 dl_lon1(:,:)=dd_lon1(:,:) 3838 WHERE( dd_lon1(:,:) < 0 ) dl_lon1(:,:)=dd_lon1(:,:)+360. 3984 WHERE( dd_lon1(:,:) < 0 ) dl_lon1(:,:)=dd_lon1(:,:)+360. 3839 3985 3840 3986 ! init 3841 3987 grid__get_fine_offset_cc(:,:)=-1 3988 ll_greenwich=.FALSE. 3842 3989 3843 3990 IF( il_shape1(jp_J) == 1 )THEN 3844 3991 3845 3992 grid__get_fine_offset_cc(jp_J,:)=((id_rho(jp_J)-1)/2) 3846 3993 3847 ! work on i-direction 3848 ! look for i-direction left offset 3849 IF( dl_lon1(1,1) < dl_lon0(id_imin0+1,id_jmin0) )THEN 3850 DO ji=1,id_rho(jp_I)+2 3851 IF( dl_lon1(ji,1) > dl_lon0(id_imin0+1,id_jmin0) - dp_delta )THEN 3852 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ji 3853 EXIT 3854 ENDIF 3855 ENDDO 3994 !!! work on i-direction 3995 !!! look for i-direction left offset 3996 i1=1 ; i2=MIN((id_rho(jp_I)+2),il_shape1(jp_I)) 3997 j1=1 ; j2=1 3998 3999 ! check if cross greenwich meridien 4000 IF( minval(dl_lon0(id_imin0:id_imin0+1,id_jmin0))<5. .OR. & 4001 & maxval(dl_lon0(id_imin0:id_imin0+1,id_jmin0))>355. )THEN 4002 ! close to greenwich meridien 4003 ll_greenwich=.TRUE. 4004 ! 0:360 => -180:180 4005 WHERE( dl_lon0(id_imin0:id_imin0+1,id_jmin0) > 180. ) 4006 dl_lon0(id_imin0:id_imin0+1,id_jmin0) = & 4007 & dl_lon0(id_imin0:id_imin0+1,id_jmin0)-360. 4008 END WHERE 4009 4010 WHERE( dl_lon1(i1:i2,j1:j2) > 180. ) 4011 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)-360. 4012 END WHERE 4013 ENDIF 4014 4015 ! max lognitude of the left cell 4016 dl_lonmax0=dl_lon0(id_imin0+1,id_jmin0) 4017 IF( dl_lon1(1,1) < dl_lonmax0 )THEN 4018 4019 !!!!! i-direction !!!!! 4020 IF( ll_even(jp_I) )THEN 4021 ! even 4022 SELECT CASE(TRIM(cl_point)) 4023 CASE('F','U') 4024 dl_dlon= ( dl_lon0(id_imin0+1,id_jmin0) - & 4025 & dl_lon0(id_imin0 ,id_jmin0) ) / & 4026 & ( 2.*id_rho(jp_I) ) 4027 CASE DEFAULT 4028 dl_dlon=0 4029 END SELECT 4030 ELSE 4031 ! odd 4032 dl_dlon= ( dl_lon0(id_imin0+1,id_jmin0) - & 4033 & dl_lon0(id_imin0 ,id_jmin0) ) / & 4034 & ( 2.*id_rho(jp_I) ) 4035 ENDIF 4036 4037 dl_lon0F= dl_lon0(id_imin0+1,id_jmin0) + dl_dlon 4038 dl_lat0F= dd_lat0(id_imin0+1,id_jmin0) 4039 4040 il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & 4041 & dl_lon0F, dl_lat0F, 'le' ) 4042 4043 ii=il_ind(1) 4044 4045 !!!!! i-direction !!!!! 4046 IF( ll_even(jp_I) )THEN 4047 ! even 4048 SELECT CASE(TRIM(cl_point)) 4049 CASE('T','V') 4050 grid__get_fine_offset_cc(jp_I,1)=id_rho(jp_I)-ii 4051 CASE DEFAULT !'F','U' 4052 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 4053 END SELECT 4054 ELSE 4055 ! odd 4056 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 4057 ENDIF 4058 3856 4059 ELSE 3857 4060 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3858 & " not match fine grid lower left corner.") 3859 ENDIF 3860 ! look for i-direction right offset 3861 IF( dl_lon1(il_shape1(jp_I),1) > dl_lon0(id_imax0-1,id_jmin0) )THEN 3862 DO ji=1,id_rho(jp_I)+2 3863 ii=il_shape1(jp_I)-ji+1 3864 IF( dl_lon1(ii,1) < dl_lon0(id_imax0-1,id_jmin0) + dp_delta )THEN 3865 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-ji 3866 EXIT 3867 ENDIF 3868 ENDDO 4061 & " not match fine grid left corner.") 4062 ENDIF 4063 4064 IF( ll_greenwich )THEN 4065 ! close to greenwich meridien 4066 ll_greenwich=.FALSE. 4067 ! -180:180 => 0:360 4068 WHERE( dl_lon0(id_imin0:id_imin0+1,id_jmin0) < 0. ) 4069 dl_lon0(id_imin0:id_imin0+1,id_jmin0) = & 4070 & dl_lon0(id_imin0:id_imin0+1,id_jmin0)+360. 4071 END WHERE 4072 4073 WHERE( dl_lon1(i1:i2,j1:j2) < 0. ) 4074 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)+360. 4075 END WHERE 4076 ENDIF 4077 4078 !!!!!! look for i-direction right offset !!!!!! 4079 i1=MAX(1,il_shape1(jp_I)-(id_rho(jp_I)+2)+1) ; i2=il_shape1(jp_I) 4080 j1=1 ; j2=1 4081 4082 ! check if cross greenwich meridien 4083 IF( minval(dl_lon0(id_imax0-1:id_imax0,id_jmin0))<5. .OR. & 4084 & maxval(dl_lon0(id_imax0-1:id_imax0,id_jmin0))>355. )THEN 4085 ! close to greenwich meridien 4086 ll_greenwich=.TRUE. 4087 ! 0:360 => -180:180 4088 WHERE( dl_lon0(id_imax0-1:id_imax0,id_jmin0) > 180. ) 4089 dl_lon0(id_imax0-1:id_imax0,id_jmin0) = & 4090 & dl_lon0(id_imax0-1:id_imax0,id_jmin0)-360. 4091 END WHERE 4092 4093 WHERE( dl_lon1(i1:i2,j1:j2) > 180. ) 4094 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)-360. 4095 END WHERE 4096 ENDIF 4097 4098 ! min lognitude of the right cell 4099 dl_lonmin0=dl_lon0(id_imax0-1,id_jmin0) 4100 IF( dl_lon1(il_shape1(jp_I),il_shape1(jp_J)) > dl_lonmin0 )THEN 4101 4102 !!!!! i-direction !!!!! 4103 IF( ll_even(jp_I) )THEN 4104 ! even 4105 SELECT CASE(TRIM(cl_point)) 4106 CASE('F','U') 4107 dl_dlon= ( dl_lon0(id_imax0 ,id_jmin0) - & 4108 & dl_lon0(id_imax0-1,id_jmin0) ) / & 4109 & ( 2.*id_rho(jp_I) ) 4110 CASE DEFAULT 4111 dl_dlon=0 4112 END SELECT 4113 ELSE 4114 ! odd 4115 dl_dlon= ( dl_lon0(id_imax0 ,id_jmin0) - & 4116 & dl_lon0(id_imax0-1,id_jmin0) ) / & 4117 & ( 2.*id_rho(jp_I) ) 4118 ENDIF 4119 4120 dl_lon0F= dl_lon0(id_imax0-1,id_jmin0) - dl_dlon 4121 dl_lat0F= dd_lat0(id_imax0-1,id_jmin0) 4122 4123 il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & 4124 & dl_lon0F, dl_lat0F, 'ri' ) 4125 4126 ii=(MIN(il_shape1(jp_I),(id_rho(jp_I)+2))-il_ind(1)+1) 4127 4128 !!!!! i-direction !!!!! 4129 IF( ll_even(jp_I) )THEN 4130 ! even 4131 SELECT CASE(TRIM(cl_point)) 4132 CASE('T','V') 4133 grid__get_fine_offset_cc(jp_I,2)=id_rho(jp_I)-ii 4134 CASE DEFAULT !'F','U' 4135 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-ii 4136 END SELECT 4137 ELSE 4138 ! odd 4139 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-ii 4140 ENDIF 4141 3869 4142 ELSE 3870 4143 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3871 & " not match fine grid lower right corner.") 4144 & " not match fine grid right corner.") 4145 ENDIF 4146 4147 IF( ll_greenwich )THEN 4148 ! close to greenwich meridien 4149 ll_greenwich=.FALSE. 4150 ! -180:180 => 0:360 4151 WHERE( dl_lon0(id_imax0-1:id_imax0,id_jmin0) < 0. ) 4152 dl_lon0(id_imax0-1:id_imax0,id_jmin0) = & 4153 & dl_lon0(id_imax0-1:id_imax0,id_jmin0)+360. 4154 END WHERE 4155 4156 WHERE( dl_lon1(i1:i2,j1:j2) < 0. ) 4157 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)+360. 4158 END WHERE 3872 4159 ENDIF 3873 4160 … … 3876 4163 grid__get_fine_offset_cc(jp_I,:)=((id_rho(jp_I)-1)/2) 3877 4164 3878 ! work on j-direction 3879 3880 ! look for j-direction lower offset 3881 IF( dd_lat1(1,1) < dd_lat0(id_imin0,id_jmin0+1) )THEN 3882 DO jj=1,id_rho(jp_J)+2 3883 IF( dd_lat1(1,jj) > dd_lat0(id_imin0,id_jmin0+1) - dp_delta )THEN 3884 grid__get_fine_offset_cc(jp_J,1)=(id_rho(jp_J)+1)-jj 3885 EXIT 3886 ENDIF 3887 ENDDO 4165 !!! work on j-direction 4166 !!! look for j-direction lower offset 4167 i1=1 ; i2=1 4168 j1=1 ; j2=MIN((id_rho(jp_J)+2),il_shape1(jp_J)) 4169 4170 4171 ! max latitude of the lower cell 4172 dl_latmax0=dd_lat0(id_imin0,id_jmin0+1) 4173 IF( dd_lat1(1,1) < dl_latmax0 )THEN 4174 4175 IF( ll_even(jp_J) )THEN 4176 ! even 4177 SELECT CASE(TRIM(cl_point)) 4178 CASE('F','V') 4179 dl_dlat= ( dd_lat0(id_imin0,id_jmin0+1) - & 4180 & dd_lat0(id_imin0,id_jmin0 ) ) / & 4181 & ( 2.*id_rho(jp_J) ) 4182 CASE DEFAULT 4183 dl_dlat=0 4184 END SELECT 4185 ELSE 4186 ! odd 4187 dl_dlat= ( dd_lat0(id_imin0,id_jmin0+1) - & 4188 & dd_lat0(id_imin0,id_jmin0 ) ) / & 4189 & ( 2.*id_rho(jp_J) ) 4190 ENDIF 4191 4192 dl_lon0F= dl_lon0(id_imin0,id_jmin0+1) 4193 dl_lat0F= dd_lat0(id_imin0,id_jmin0+1) + dl_dlat 4194 4195 il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & 4196 & dl_lon0F, dl_lat0F, 'lo' ) 4197 4198 ij=il_ind(2) 4199 4200 !!!!! i-direction !!!!! 4201 IF( ll_even(jp_I) )THEN 4202 ! even 4203 SELECT CASE(TRIM(cl_point)) 4204 CASE('T','V') 4205 grid__get_fine_offset_cc(jp_I,1)=id_rho(jp_I)-ii 4206 CASE DEFAULT !'F','U' 4207 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 4208 END SELECT 4209 ELSE 4210 ! odd 4211 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 4212 ENDIF 4213 3888 4214 ELSE 3889 4215 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3890 & " not match fine grid upper left corner.") 3891 ENDIF 3892 3893 ! look for j-direction upper offset 3894 IF( dd_lat1(1,il_shape1(jp_J)) > dd_lat0(id_imin0,id_jmax0-1) )THEN 3895 DO jj=1,id_rho(jp_J)+2 3896 ij=il_shape1(jp_J)-jj+1 3897 IF( dd_lat1(1,ij) < dd_lat0(id_imin0,id_jmax0-1) + dp_delta )THEN 3898 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-jj 3899 EXIT 3900 ENDIF 3901 ENDDO 4216 & " not match fine grid lower corner.") 4217 ENDIF 4218 4219 !!! look for j-direction upper offset 4220 i1=1 ; i2=1 4221 j1=MAX(1,il_shape1(jp_J)-(id_rho(jp_J)+2)+1) ; j2=il_shape1(jp_J) 4222 4223 ! min latitude of the upper cell 4224 dl_latmin0=dd_lat0(id_imin0,id_jmax0-1) 4225 IF( dd_lat1(il_shape1(jp_I),il_shape1(jp_J)) > dl_latmin0 )THEN 4226 4227 IF( ll_even(jp_J) )THEN 4228 ! even 4229 SELECT CASE(TRIM(cl_point)) 4230 CASE('F','V') 4231 dl_dlat= ( dd_lat0(id_imin0,id_jmax0 ) - & 4232 & dd_lat0(id_imin0,id_jmax0-1) ) / & 4233 & ( 2.*id_rho(jp_J) ) 4234 CASE DEFAULT 4235 dl_dlat=0 4236 END SELECT 4237 ELSE 4238 ! odd 4239 dl_dlat= ( dd_lat0(id_imin0,id_jmax0 ) - & 4240 & dd_lat0(id_imin0,id_jmax0-1) ) / & 4241 & ( 2*id_rho(jp_J) ) 4242 ENDIF 4243 4244 dl_lon0F= dl_lon0(id_imin0,id_jmax0-1) 4245 dl_lat0F= dd_lat0(id_imin0,id_jmax0-1) - dl_dlat 4246 4247 il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & 4248 & dl_lon0F, dl_lat0F, 'up' ) 4249 4250 ij=(MIN(il_shape1(jp_J),(id_rho(jp_J)+2))-il_ind(2)+1) 4251 4252 !!!!! j-direction !!!!! 4253 IF( ll_even(jp_J) )THEN 4254 ! even 4255 SELECT CASE(TRIM(cl_point)) 4256 CASE('T','U') 4257 grid__get_fine_offset_cc(jp_J,2)=id_rho(jp_J)-ij 4258 CASE DEFAULT !'F','V' 4259 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-ij 4260 END SELECT 4261 ELSE 4262 ! odd 4263 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-ij 4264 ENDIF 4265 3902 4266 ELSE 3903 4267 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 4268 & " not match fine grid upper corner.") 4269 ENDIF 4270 4271 ELSE ! il_shape1(1) > 1 .AND. il_shape1(2) > 1 4272 4273 !!!!!! look for lower left offset !!!!!! 4274 i1=1 ; i2=MIN((id_rho(jp_I)+2),il_shape1(jp_I)) 4275 j1=1 ; j2=MIN((id_rho(jp_J)+2),il_shape1(jp_J)) 4276 4277 ! check if cross greenwich meridien 4278 IF( minval(dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1))<5. .OR. & 4279 & maxval(dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1))>355. )THEN 4280 ! close to greenwich meridien 4281 ll_greenwich=.TRUE. 4282 ! 0:360 => -180:180 4283 WHERE( dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1) > 180. ) 4284 dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1) = & 4285 & dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1)-360. 4286 END WHERE 4287 4288 WHERE( dl_lon1(i1:i2,j1:j2) > 180. ) 4289 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)-360. 4290 END WHERE 4291 ENDIF 4292 4293 ! max longitude of the lower left cell 4294 dl_lonmax0=MAX(dl_lon0(id_imin0+1,id_jmin0),dl_lon0(id_imin0+1,id_jmin0+1)) 4295 ! max latitude of the lower left cell 4296 dl_latmax0=MAX(dd_lat0(id_imin0,id_jmin0+1),dd_lat0(id_imin0+1,id_jmin0+1)) 4297 IF( dl_lon1(1,1) < dl_lonmax0 .AND. & 4298 & dd_lat1(1,1) < dl_latmax0 )THEN 4299 4300 !!!!! i-direction !!!!! 4301 IF( ll_even(jp_I) )THEN 4302 ! even 4303 SELECT CASE(TRIM(cl_point)) 4304 CASE('F','U') 4305 dl_dlon= ( dl_lon0(id_imin0+1,id_jmin0+1) - & 4306 & dl_lon0(id_imin0 ,id_jmin0+1) ) / & 4307 & ( 2.*id_rho(jp_I) ) 4308 CASE DEFAULT 4309 dl_dlon=0 4310 END SELECT 4311 ELSE 4312 ! odd 4313 dl_dlon= ( dl_lon0(id_imin0+1,id_jmin0+1) - & 4314 & dl_lon0(id_imin0 ,id_jmin0+1) ) / & 4315 & ( 2.*id_rho(jp_I) ) 4316 ENDIF 4317 4318 !!!!! j-direction !!!!! 4319 IF( ll_even(jp_J) )THEN 4320 ! even 4321 SELECT CASE(TRIM(cl_point)) 4322 CASE('F','V') 4323 dl_dlat= ( dd_lat0(id_imin0+1,id_jmin0+1) - & 4324 & dd_lat0(id_imin0+1,id_jmin0 ) ) / & 4325 & ( 2.*id_rho(jp_J) ) 4326 CASE DEFAULT 4327 dl_dlat=0 4328 END SELECT 4329 ELSE 4330 ! odd 4331 dl_dlat= ( dd_lat0(id_imin0+1,id_jmin0+1) - & 4332 & dd_lat0(id_imin0+1,id_jmin0 ) ) / & 4333 & ( 2.*id_rho(jp_J) ) 4334 ENDIF 4335 4336 dl_lon0F= dl_lon0(id_imin0+1,id_jmin0+1) + dl_dlon 4337 dl_lat0F= dd_lat0(id_imin0+1,id_jmin0+1) + dl_dlat 4338 4339 il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & 4340 & dl_lon0F, dl_lat0F, 'll' ) 4341 4342 ii=il_ind(1) 4343 ij=il_ind(2) 4344 4345 !!!!! i-direction !!!!! 4346 IF( ll_even(jp_I) )THEN 4347 ! even 4348 SELECT CASE(TRIM(cl_point)) 4349 CASE('T','V') 4350 grid__get_fine_offset_cc(jp_I,1)=id_rho(jp_I)-ii 4351 CASE DEFAULT !'F','U' 4352 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 4353 END SELECT 4354 ELSE 4355 ! odd 4356 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 4357 ENDIF 4358 4359 !!!!! j-direction !!!!! 4360 IF( ll_even(jp_J) )THEN 4361 ! even 4362 SELECT CASE(TRIM(cl_point)) 4363 CASE('T','U') 4364 grid__get_fine_offset_cc(jp_J,1)=id_rho(jp_J)-ij 4365 CASE DEFAULT !'F','V' 4366 grid__get_fine_offset_cc(jp_J,1)=(id_rho(jp_J)+1)-ij 4367 END SELECT 4368 ELSE 4369 ! odd 4370 grid__get_fine_offset_cc(jp_J,1)=(id_rho(jp_J)+1)-ij 4371 ENDIF 4372 4373 ELSE 4374 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do"//& 4375 & " not match fine grid lower left corner.") 4376 ENDIF 4377 4378 IF( ll_greenwich )THEN 4379 ! close to greenwich meridien 4380 ll_greenwich=.FALSE. 4381 ! -180:180 => 0:360 4382 WHERE( dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1) < 0. ) 4383 dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1) = & 4384 & dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1)+360. 4385 END WHERE 4386 4387 WHERE( dl_lon1(i1:i2,j1:j2) < 0. ) 4388 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)+360. 4389 END WHERE 4390 ENDIF 4391 4392 !!!!!! look for upper right offset !!!!!! 4393 i1=MAX(1,il_shape1(jp_I)-(id_rho(jp_I)+2)+1) ; i2=il_shape1(jp_I) 4394 j1=MAX(1,il_shape1(jp_J)-(id_rho(jp_J)+2)+1) ; j2=il_shape1(jp_J) 4395 4396 ! check if cross greenwich meridien 4397 IF( minval(dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0))<5. .OR. & 4398 & maxval(dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0))>355. )THEN 4399 ! close to greenwich meridien 4400 ll_greenwich=.TRUE. 4401 ! 0:360 => -180:180 4402 WHERE( dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0) > 180. ) 4403 dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0) = & 4404 & dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0)-360. 4405 END WHERE 4406 4407 WHERE( dl_lon1(i1:i2,j1:j2) > 180. ) 4408 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)-360. 4409 END WHERE 4410 ENDIF 4411 4412 ! min latitude of the upper right cell 4413 dl_lonmin0=MIN(dl_lon0(id_imax0-1,id_jmax0-1),dl_lon0(id_imax0-1,id_jmax0)) 4414 ! min latitude of the upper right cell 4415 dl_latmin0=MIN(dd_lat0(id_imax0-1,id_jmax0-1),dd_lat0(id_imax0,id_jmax0-1)) 4416 IF( dl_lon1(il_shape1(jp_I),il_shape1(jp_J)) > dl_lonmin0 .AND. & 4417 & dd_lat1(il_shape1(jp_I),il_shape1(jp_J)) > dl_latmin0 )THEN 4418 4419 !!!!! i-direction !!!!! 4420 IF( ll_even(jp_I) )THEN 4421 ! even 4422 SELECT CASE(TRIM(cl_point)) 4423 CASE('F','U') 4424 dl_dlon= ( dl_lon0(id_imax0 ,id_jmax0-1) - & 4425 & dl_lon0(id_imax0-1,id_jmax0-1) ) / & 4426 & ( 2.*id_rho(jp_I) ) 4427 CASE DEFAULT 4428 dl_dlon=0 4429 END SELECT 4430 ELSE 4431 ! odd 4432 dl_dlon= ( dl_lon0(id_imax0 ,id_jmax0-1) - & 4433 & dl_lon0(id_imax0-1,id_jmax0-1) ) / & 4434 & ( 2*id_rho(jp_I) ) 4435 ENDIF 4436 4437 !!!!! j-direction !!!!! 4438 IF( ll_even(jp_J) )THEN 4439 ! even 4440 SELECT CASE(TRIM(cl_point)) 4441 CASE('F','V') 4442 dl_dlat= ( dd_lat0(id_imax0-1,id_jmax0 ) - & 4443 & dd_lat0(id_imax0-1,id_jmax0-1) ) / & 4444 & ( 2.*id_rho(jp_J) ) 4445 CASE DEFAULT 4446 dl_dlat=0 4447 END SELECT 4448 ELSE 4449 ! odd 4450 dl_dlat= ( dd_lat0(id_imax0-1,id_jmax0 ) - & 4451 & dd_lat0(id_imax0-1,id_jmax0-1) ) / & 4452 & ( 2*id_rho(jp_J) ) 4453 ENDIF 4454 4455 dl_lon0F= dl_lon0(id_imax0-1,id_jmax0-1) - dl_dlon 4456 dl_lat0F= dd_lat0(id_imax0-1,id_jmax0-1) - dl_dlat 4457 4458 il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & 4459 & dl_lon0F, dl_lat0F, 'ur' ) 4460 4461 ii=(MIN(il_shape1(jp_I),(id_rho(jp_I)+2))-il_ind(1)+1) 4462 ij=(MIN(il_shape1(jp_J),(id_rho(jp_J)+2))-il_ind(2)+1) 4463 4464 !!!!! i-direction !!!!! 4465 IF( ll_even(jp_I) )THEN 4466 ! even 4467 SELECT CASE(TRIM(cl_point)) 4468 CASE('T','V') 4469 grid__get_fine_offset_cc(jp_I,2)=id_rho(jp_I)-ii 4470 CASE DEFAULT !'F','U' 4471 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-ii 4472 END SELECT 4473 ELSE 4474 ! odd 4475 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-ii 4476 ENDIF 4477 4478 !!!!! j-direction !!!!! 4479 IF( ll_even(jp_J) )THEN 4480 ! even 4481 SELECT CASE(TRIM(cl_point)) 4482 CASE('T','U') 4483 grid__get_fine_offset_cc(jp_J,2)=id_rho(jp_J)-ij 4484 CASE DEFAULT !'F','V' 4485 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-ij 4486 END SELECT 4487 ELSE 4488 ! odd 4489 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-ij 4490 ENDIF 4491 4492 ELSE 4493 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do"//& 3904 4494 & " not match fine grid upper right corner.") 3905 ENDIF 3906 3907 ELSE ! il_shape1(1) > 1 .AND. il_shape1(2) > 1 3908 3909 ! look for lower left offset 3910 IF( dl_lon1(1,1) < dl_lon0(id_imin0+1,id_jmin0+1) )THEN 3911 3912 ii=1 3913 ij=1 3914 DO ji=1,(id_rho(jp_I)+2)*(id_rho(jp_J)+2) 3915 3916 ll_ii=.FALSE. 3917 ll_ij=.FALSE. 3918 3919 IF( dl_lon1(ii,ij) >= dl_lon0(id_imin0+1,id_jmin0+1)-dp_delta .AND. & 3920 & dd_lat1(ii,ij) >= dd_lat0(id_imin0+1,id_jmin0+1)-dp_delta )THEN 3921 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 3922 grid__get_fine_offset_cc(jp_J,1)=(id_rho(jp_J)+1)-ij 3923 EXIT 3924 ENDIF 3925 3926 IF( dl_lon1(ii+1,ij) <= dl_lon0(id_imin0+1,id_jmin0+1)+dp_delta .AND. & 3927 & dd_lat1(ii+1,ij) <= dd_lat0(id_imin0+1,id_jmin0+1)+dp_delta )THEN 3928 ll_ii=.TRUE. 3929 ENDIF 3930 IF( dl_lon1(ii,ij+1) <= dl_lon0(id_imin0+1,id_jmin0+1)+dp_delta .AND. & 3931 & dd_lat1(ii,ij+1) <= dd_lat0(id_imin0+1,id_jmin0+1)+dp_delta )THEN 3932 ll_ij=.TRUE. 3933 ENDIF 3934 3935 IF( ll_ii ) ii=ii+1 3936 IF( ll_ij ) ij=ij+1 3937 3938 ENDDO 3939 3940 ELSE 3941 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3942 & " not match fine grid lower left corner.") 3943 ENDIF 3944 3945 ! look for upper right offset 3946 IF( dl_lon1(il_shape1(jp_I),il_shape1(jp_J)) > & 3947 & dl_lon0(id_imax0-1,id_jmax0-1) )THEN 3948 3949 ii=il_shape1(jp_I) 3950 ij=il_shape1(jp_J) 3951 DO ji=1,(id_rho(jp_I)+2)*(id_rho(jp_J)+2) 3952 3953 ll_ii=.FALSE. 3954 ll_ij=.FALSE. 3955 3956 IF( dl_lon1(ii,ij) <= dl_lon0(id_imax0-1,id_jmax0-1)+dp_delta .AND. & 3957 & dd_lat1(ii,ij) <= dd_lat0(id_imax0-1,id_jmax0-1)+dp_delta )THEN 3958 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-(il_shape1(jp_I)+1-ii) 3959 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-(il_shape1(jp_J)+1-ij) 3960 EXIT 3961 ENDIF 3962 3963 IF( dl_lon1(ii-1,ij) >= dl_lon0(id_imax0-1,id_jmax0-1)-dp_delta .AND. & 3964 & dd_lat1(ii-1,ij) >= dd_lat0(id_imax0-1,id_jmax0-1)-dp_delta )THEN 3965 ll_ii=.TRUE. 3966 ENDIF 3967 IF( dl_lon1(ii,ij-1) >= dl_lon0(id_imax0-1,id_jmax0-1)-dp_delta .AND. & 3968 & dd_lat1(ii,ij-1) >= dd_lat0(id_imax0-1,id_jmax0-1)-dp_delta )THEN 3969 ll_ij=.TRUE. 3970 ENDIF 3971 3972 IF( ll_ii ) ii=ii-1 3973 IF( ll_ij ) ij=ij-1 3974 3975 ENDDO 3976 3977 ELSE 3978 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3979 & " not match fine grid upper right corner.") 4495 ENDIF 4496 4497 IF( ll_greenwich )THEN 4498 ! close to greenwich meridien 4499 ll_greenwich=.FALSE. 4500 ! -180:180 => 0:360 4501 WHERE( dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0) < 0. ) 4502 dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0) = & 4503 & dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0)+360. 4504 END WHERE 4505 4506 WHERE( dl_lon1(i1:i2,j1:j2) < 0. ) 4507 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)+360. 4508 END WHERE 3980 4509 ENDIF 3981 4510 … … 3984 4513 DEALLOCATE( dl_lon0 ) 3985 4514 DEALLOCATE( dl_lon1 ) 4515 4516 IF( ANY(grid__get_fine_offset_cc(:,:)==-1) )THEN 4517 CALL logger_fatal("GRID GET FINE OFFSET: can not found "//& 4518 & " offset between coarse and fine grid.") 4519 ENDIF 3986 4520 3987 4521 END FUNCTION grid__get_fine_offset_cc … … 3995 4529 !> @date October, 2014 3996 4530 !> - work on mpp file structure instead of file structure 3997 ! 4531 !> @date February, 2016 4532 !> - use F-point to check coincidence for even refinment 4533 !> - use F-point estimation, if can not read it. 4534 !> 3998 4535 !> @param[in] td_coord0 coarse grid coordinate file structure 3999 4536 !> @param[in] td_coord1 fine grid coordinate file structure … … 4020 4557 4021 4558 ! local variable 4022 INTEGER(i4) :: il_imid14023 INTEGER(i4) :: il_jmid14559 INTEGER(i4) :: il_imid1 4560 INTEGER(i4) :: il_jmid1 4024 4561 4025 INTEGER(i4) :: il_ew0 4026 INTEGER(i4) :: il_ew1 4027 4028 INTEGER(i4) :: il_imin1 4029 INTEGER(i4) :: il_imax1 4030 INTEGER(i4) :: il_jmin1 4031 INTEGER(i4) :: il_jmax1 4032 4033 INTEGER(i4), DIMENSION(2) :: il_indC 4034 INTEGER(i4), DIMENSION(2) :: il_indF 4035 INTEGER(i4), DIMENSION(2) :: il_iind 4036 INTEGER(i4), DIMENSION(2) :: il_jind 4037 4038 REAL(dp) :: dl_lon0 4039 REAL(dp) :: dl_lat0 4040 REAL(dp) :: dl_lon1 4041 REAL(dp) :: dl_lat1 4042 4043 REAL(dp) :: dl_lon1p 4044 REAL(dp) :: dl_lat1p 4045 4046 LOGICAL :: ll_coincidence 4047 4048 TYPE(TVAR) :: tl_lon0 4049 TYPE(TVAR) :: tl_lat0 4050 TYPE(TVAR) :: tl_lon1 4051 TYPE(TVAR) :: tl_lat1 4052 4053 TYPE(TMPP) :: tl_coord0 4054 TYPE(TMPP) :: tl_coord1 4055 4056 TYPE(TDOM) :: tl_dom0 4562 INTEGER(i4) :: il_ew0 4563 INTEGER(i4) :: il_ew1 4564 4565 INTEGER(i4) :: il_ind 4566 4567 INTEGER(i4) :: il_imin1 4568 INTEGER(i4) :: il_imax1 4569 INTEGER(i4) :: il_jmin1 4570 INTEGER(i4) :: il_jmax1 4571 4572 INTEGER(i4), DIMENSION(2) :: il_ind0 4573 INTEGER(i4), DIMENSION(2) :: il_ind1 4574 4575 INTEGER(i4), DIMENSION(2) :: il_ill1 4576 INTEGER(i4), DIMENSION(2) :: il_ilr1 4577 INTEGER(i4), DIMENSION(2) :: il_iul1 4578 INTEGER(i4), DIMENSION(2) :: il_iur1 4579 4580 REAL(dp) :: dl_lon0F 4581 REAL(dp) :: dl_lat0F 4582 REAL(dp) :: dl_lon0 4583 REAL(dp) :: dl_lat0 4584 REAL(dp) :: dl_lon1F 4585 REAL(dp) :: dl_lat1F 4586 REAL(dp) :: dl_lon1 4587 REAL(dp) :: dl_lat1 4588 4589 REAL(dp) :: dl_delta 4590 4591 LOGICAL :: ll_coincidence 4592 LOGICAL :: ll_even 4593 LOGICAL :: ll_grid0F 4594 LOGICAL :: ll_grid1F 4595 4596 TYPE(TVAR) :: tl_lon0 4597 TYPE(TVAR) :: tl_lat0 4598 TYPE(TVAR) :: tl_lon0F 4599 TYPE(TVAR) :: tl_lat0F 4600 TYPE(TVAR) :: tl_lon1 4601 TYPE(TVAR) :: tl_lat1 4602 TYPE(TVAR) :: tl_lon1F 4603 TYPE(TVAR) :: tl_lat1F 4604 4605 TYPE(TMPP) :: tl_coord0 4606 TYPE(TMPP) :: tl_coord1 4607 4608 TYPE(TDOM) :: tl_dom0 4057 4609 4058 4610 ! loop indices … … 4063 4615 ll_coincidence=.TRUE. 4064 4616 4617 ll_even=.FALSE. 4618 IF( MOD(id_rho(jp_I)*id_rho(jp_J),2) == 0 )THEN 4619 ll_even=.TRUE. 4620 ENDIF 4621 4065 4622 ! copy structure 4066 4623 tl_coord0=mpp_copy(td_coord0) … … 4075 4632 4076 4633 ! read variable value on domain 4077 tl_lon0=iom_dom_read_var(tl_coord0,'longitude',tl_dom0) 4078 tl_lat0=iom_dom_read_var(tl_coord0,'latitude' ,tl_dom0) 4634 il_ind=var_get_index(tl_coord0%t_proc(1)%t_var(:), 'longitude_T') 4635 IF( il_ind /= 0 )THEN 4636 tl_lon0=iom_dom_read_var(tl_coord0,'longitude_T',tl_dom0) 4637 ELSE 4638 tl_lon0=iom_dom_read_var(tl_coord0,'longitude',tl_dom0) 4639 ENDIF 4640 4641 il_ind=var_get_index(tl_coord0%t_proc(1)%t_var(:), 'latitude_T') 4642 IF( il_ind /= 0 )THEN 4643 tl_lat0=iom_dom_read_var(tl_coord0,'latitude_T' ,tl_dom0) 4644 ELSE 4645 tl_lat0=iom_dom_read_var(tl_coord0,'latitude' ,tl_dom0) 4646 ENDIF 4647 4648 IF( ll_even )THEN 4649 ! look for variable value on domain for F point 4650 il_ind=var_get_index(tl_coord0%t_proc(1)%t_var(:), 'longitude_F') 4651 IF( il_ind /= 0 )THEN 4652 tl_lon0F=iom_dom_read_var(tl_coord0,'longitude_F',tl_dom0) 4653 ENDIF 4654 4655 il_ind=var_get_index(tl_coord0%t_proc(1)%t_var(:), 'latitude_F') 4656 IF( il_ind /= 0 )THEN 4657 tl_lat0F=iom_dom_read_var(tl_coord0,'latitude_F' ,tl_dom0) 4658 ENDIF 4659 4660 ll_grid0F=.FALSE. 4661 IF( ASSOCIATED(tl_lon0F%d_value) .AND. & 4662 & ASSOCIATED(tl_lat0F%d_value) )THEN 4663 ll_grid0F=.TRUE. 4664 ENDIF 4665 4666 ENDIF 4079 4667 4080 4668 ! close mpp files … … 4092 4680 4093 4681 ! read fine longitue and latitude 4094 tl_lon1=iom_mpp_read_var(tl_coord1,'longitude') 4095 tl_lat1=iom_mpp_read_var(tl_coord1,'latitude') 4682 il_ind=var_get_index(tl_coord1%t_proc(1)%t_var(:), TRIM(tl_lon0%c_longname)) 4683 IF( il_ind /= 0 )THEN 4684 tl_lon1=iom_mpp_read_var(tl_coord1,TRIM(tl_lon0%c_longname)) 4685 ELSE 4686 tl_lon1=iom_mpp_read_var(tl_coord1,'longitude') 4687 ENDIF 4688 il_ind=var_get_index(tl_coord1%t_proc(1)%t_var(:), TRIM(tl_lat0%c_longname)) 4689 IF( il_ind /= 0 )THEN 4690 tl_lat1=iom_mpp_read_var(tl_coord1,TRIM(tl_lat0%c_longname)) 4691 ELSE 4692 tl_lat1=iom_mpp_read_var(tl_coord1,'latitude') 4693 ENDIF 4096 4694 4695 IF( ll_even )THEN 4696 4697 ! look for variable value on domain for F point 4698 il_ind=var_get_index(tl_coord1%t_proc(1)%t_var(:), 'longitude_F') 4699 IF( il_ind /= 0 )THEN 4700 tl_lon1F=iom_mpp_read_var(tl_coord1,'longitude_F') 4701 ENDIF 4702 4703 il_ind=var_get_index(tl_coord1%t_proc(1)%t_var(:), 'latitude_F') 4704 IF( il_ind /= 0 )THEN 4705 tl_lat1F=iom_mpp_read_var(tl_coord1,'latitude_F') 4706 ENDIF 4707 4708 ll_grid1F=.FALSE. 4709 IF( ASSOCIATED(tl_lon1F%d_value) .AND. & 4710 & ASSOCIATED(tl_lat1F%d_value) )THEN 4711 ll_grid1F=.TRUE. 4712 ENDIF 4713 4714 ENDIF 4715 4097 4716 ! close mpp files 4098 CALL iom_ dom_close(tl_coord1)4717 CALL iom_mpp_close(tl_coord1) 4099 4718 ! clean structure 4100 4719 CALL mpp_clean(tl_coord1) … … 4158 4777 IF( .NOT. ll_coincidence )THEN 4159 4778 CALL logger_fatal("GRID CHECK COINCIDENCE: no coincidence "//& 4160 & "between fine grid and coarse grid . invalid domain" )4779 & "between fine grid and coarse grid: invalid domain." ) 4161 4780 ENDIF 4162 4781 … … 4172 4791 4173 4792 ! select closest point on coarse grid 4174 il_ind C(:)=grid_get_closest(tl_lon0%d_value(:,:,1,1),&4793 il_ind0(:)=grid_get_closest(tl_lon0%d_value(:,:,1,1),& 4175 4794 & tl_lat0%d_value(:,:,1,1),& 4176 4795 & dl_lon1, dl_lat1 ) 4177 4796 4178 IF( ANY(il_ind C(:)==0) )THEN4797 IF( ANY(il_ind0(:)==0) )THEN 4179 4798 CALL logger_fatal("GRID CHECK COINCIDENCE: can not find valid "//& 4180 & "coarse grid indices. invalid domain" ) 4181 ENDIF 4182 4183 dl_lon0=tl_lon0%d_value(il_indC(1),il_indC(2),1,1) 4184 dl_lat0=tl_lat0%d_value(il_indC(1),il_indC(2),1,1) 4185 4186 ! look for closest fine grid point from selected coarse grid point 4187 il_iind(:)=MAXLOC( tl_lon1%d_value(:,:,1,1), & 4188 & tl_lon1%d_value(:,:,1,1) <= dl_lon0 ) 4189 4190 il_jind(:)=MAXLOC( tl_lat1%d_value(:,:,1,1), & 4191 & tl_lat1%d_value(:,:,1,1) <= dl_lat0 ) 4192 4193 il_indF(1)=il_iind(1) 4194 il_indF(2)=il_jind(2) 4195 4196 IF( ANY(il_indF(:)==0) )THEN 4197 CALL logger_fatal("GRID CHECK COINCIDENCE: can not find valid "//& 4198 & "fine grid indices. invalid domain" ) 4199 ENDIF 4200 4201 dl_lon1=tl_lon1%d_value(il_indF(1),il_indF(2),1,1) 4202 dl_lat1=tl_lat1%d_value(il_indF(1),il_indF(2),1,1) 4203 4204 ! check i-direction refinement factor 4205 DO ji=1,MIN(3,il_imid1) 4206 4207 IF( il_indF(1)+ji*id_rho(jp_I)+1 > tl_lon1%t_dim(1)%i_len )THEN 4208 CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& 4209 & " to check i-direction refinement factor ") 4210 EXIT 4211 ELSE 4212 dl_lon1=tl_lon1%d_value(il_indF(1)+ji*id_rho(jp_I),il_indF(2),1,1) 4213 dl_lon0=tl_lon0%d_value(il_indC(1)+ji,il_indC(2),1,1) 4214 4215 dl_lon1p=tl_lon1%d_value(il_indF(1)+ji*id_rho(jp_I)+1,il_indF(2),1,1) 4216 4217 SELECT CASE(MOD(id_rho(jp_I),2)) 4218 4219 CASE(0) 4220 4221 IF( dl_lon1 >= dl_lon0 .OR. dl_lon0 >= dl_lon1p )THEN 4222 ll_coincidence=.FALSE. 4223 CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//& 4224 & "i-direction refinement factor ("//& 4225 & TRIM(fct_str(id_rho(jp_I)))//& 4226 & ") between fine grid and coarse grid ") 4227 ENDIF 4228 4229 CASE DEFAULT 4230 4799 & "coarse grid indices: invalid domain." ) 4800 ENDIF 4801 4802 IF( .NOT. ll_even )THEN 4803 ! case odd refinment in both direction 4804 ! work on T-point 4805 4806 dl_lon0=tl_lon0%d_value(il_ind0(1),il_ind0(2),1,1) 4807 dl_lat0=tl_lat0%d_value(il_ind0(1),il_ind0(2),1,1) 4808 4809 il_ind1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& 4810 & tl_lat1%d_value(:,:,1,1),& 4811 & dl_lon0, dl_lat0 ) 4812 4813 ! check i-direction refinement factor 4814 DO ji=0,MIN(3,il_imid1) 4815 4816 IF( il_ind1(1)+ji*id_rho(jp_I)+1 > tl_lon1%t_dim(1)%i_len )THEN 4817 CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& 4818 & " to check i-direction refinement factor ") 4819 EXIT 4820 ELSE 4821 dl_lon0=tl_lon0%d_value(il_ind0(1)+ji ,il_ind0(2),1,1) 4822 dl_lon1=tl_lon1%d_value(il_ind1(1)+ji*id_rho(jp_I),il_ind1(2),1,1) 4823 4824 ! assume there could be little difference due to interpolation 4231 4825 IF( ABS(dl_lon1 - dl_lon0) > dp_delta )THEN 4232 4826 ll_coincidence=.FALSE. … … 4236 4830 & ") between fine grid and coarse grid ") 4237 4831 ENDIF 4238 4239 END SELECT 4240 ENDIF 4241 4242 ENDDO 4243 4244 ! check j-direction refinement factor 4245 DO jj=1,MIN(3,il_jmid1) 4246 4247 IF( il_indF(2)+jj*id_rho(jp_J)+1 > tl_lat1%t_dim(2)%i_len )THEN 4248 CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& 4249 & " to check j-direction refinement factor ") 4250 EXIT 4251 ELSE 4252 dl_lat1=tl_lat1%d_value(il_indF(1),il_indF(2)+jj*id_rho(jp_J),1,1) 4253 dl_lat0=tl_lat0%d_value(il_indC(1),il_indC(2)+jj,1,1) 4254 4255 dl_lat1p=tl_lat1%d_value(il_indF(1),il_indF(2)+jj*id_rho(jp_J)+1,1,1) 4256 4257 SELECT CASE(MOD(id_rho(jp_J),2)) 4258 4259 CASE(0) 4260 4261 IF( dl_lat1 >= dl_lat0 .OR. dl_lat0 >= dl_lat1p )THEN 4262 ll_coincidence=.FALSE. 4263 CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//& 4264 & "j-direction refinement factor ("//& 4265 & TRIM(fct_str(id_rho(jp_J)))//& 4266 & ") between fine grid and coarse grid ") 4267 ENDIF 4268 4269 CASE DEFAULT 4270 4832 ENDIF 4833 4834 ENDDO 4835 4836 ! check j-direction refinement factor 4837 DO jj=0,MIN(3,il_jmid1) 4838 4839 IF( il_ind1(2)+jj*id_rho(jp_J)+1 > tl_lat1%t_dim(2)%i_len )THEN 4840 CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& 4841 & " to check j-direction refinement factor ") 4842 EXIT 4843 ELSE 4844 dl_lat0=tl_lat0%d_value(il_ind0(1),il_ind0(2)+jj ,1,1) 4845 dl_lat1=tl_lat1%d_value(il_ind1(1),il_ind1(2)+jj*id_rho(jp_J),1,1) 4846 4847 ! assume there could be little difference due to interpolation 4271 4848 IF( ABS(dl_lat1-dl_lat0) > dp_delta )THEN 4272 4849 ll_coincidence=.FALSE. … … 4276 4853 & ") between fine grid and coarse grid ") 4277 4854 ENDIF 4278 4279 END SELECT 4280 ENDIF 4281 4282 ENDDO 4855 ENDIF 4856 4857 ENDDO 4858 4859 ELSE 4860 ! case even refinment at least in one direction 4861 ! work on F-point 4862 4863 dl_delta=dp_delta 4864 ! look for lower left fine point in coarse cell. 4865 IF( ll_grid0F )THEN 4866 4867 ! lower left corner of coarse cell 4868 dl_lon0F=tl_lon0F%d_value(il_ind0(1)-1,il_ind0(2)-1,1,1) 4869 dl_lat0F=tl_lat0F%d_value(il_ind0(1)-1,il_ind0(2)-1,1,1) 4870 4871 ELSE 4872 4873 ! approximate lower left corner of coarse cell (with T point) 4874 dl_lon0F=( tl_lon0%d_value(il_ind0(1) ,il_ind0(2) ,1,1) + & 4875 & tl_lon0%d_value(il_ind0(1) ,il_ind0(2)-1,1,1) + & 4876 & tl_lon0%d_value(il_ind0(1)-1,il_ind0(2) ,1,1) + & 4877 & tl_lon0%d_value(il_ind0(1)-1,il_ind0(2)-1,1,1) ) * 0.25 4878 4879 dl_lat0F=( tl_lat0%d_value(il_ind0(1) ,il_ind0(2) ,1,1) + & 4880 & tl_lat0%d_value(il_ind0(1) ,il_ind0(2)-1,1,1) + & 4881 & tl_lat0%d_value(il_ind0(1)-1,il_ind0(2) ,1,1) + & 4882 & tl_lat0%d_value(il_ind0(1)-1,il_ind0(2)-1,1,1) ) * 0.25 4883 4884 ! as we use approximation of F-point we relax condition 4885 dl_delta=100*dp_delta 4886 4887 ENDIF 4888 4889 IF( ll_grid1F )THEN 4890 4891 il_ind1(:)=grid_get_closest(tl_lon1F%d_value(:,:,1,1),& 4892 & tl_lat1F%d_value(:,:,1,1),& 4893 & dl_lon0F, dl_lat0F ) 4894 4895 ELSE 4896 4897 il_ill1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& 4898 & tl_lat1%d_value(:,:,1,1),& 4899 & dl_lon0F, dl_lat0F, 'll' ) 4900 4901 il_ilr1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& 4902 & tl_lat1%d_value(:,:,1,1),& 4903 & dl_lon0F, dl_lat0F, 'lr' ) 4904 4905 il_iul1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& 4906 & tl_lat1%d_value(:,:,1,1),& 4907 & dl_lon0F, dl_lat0F, 'ul' ) 4908 4909 il_iur1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& 4910 & tl_lat1%d_value(:,:,1,1),& 4911 & dl_lon0F, dl_lat0F, 'ur' ) 4912 4913 ! as we use approximation of F-point we relax condition 4914 dl_delta=100*dp_delta 4915 4916 ENDIF 4917 4918 ! check i-direction refinement factor 4919 DO ji=0,MIN(3,il_imid1) 4920 4921 IF( il_ind1(1)+ji*id_rho(jp_I)+1 > tl_lon1%t_dim(1)%i_len )THEN 4922 CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& 4923 & " to check i-direction refinement factor ") 4924 EXIT 4925 ELSE 4926 IF( ll_grid0F )THEN 4927 dl_lon0F=tl_lon0F%d_value(il_ind0(1)+ji-1, il_ind0(2)-1,1,1) 4928 ELSE 4929 dl_lon0F= 0.25 * & 4930 & ( tl_lon0%d_value(il_ind0(1)+ji , il_ind0(2) ,1,1) + & 4931 & tl_lon0%d_value(il_ind0(1)+ji-1, il_ind0(2) ,1,1) + & 4932 & tl_lon0%d_value(il_ind0(1)+ji , il_ind0(2)-1,1,1) + & 4933 & tl_lon0%d_value(il_ind0(1)+ji-1, il_ind0(2)-1,1,1) ) 4934 ENDIF 4935 4936 IF( ll_grid1F )THEN 4937 dl_lon1F= tl_lon1F%d_value( il_ind1(1)+ji*id_rho(jp_I), & 4938 & il_ind1(2),1,1) 4939 ELSE 4940 dl_lon1F= 0.25 * & 4941 & ( tl_lon1%d_value( il_ill1(1)+ji*id_rho(jp_I), & 4942 & il_ill1(2),1,1) + & 4943 & tl_lon1%d_value( il_ilr1(1)+ji*id_rho(jp_I), & 4944 & il_ilr1(2),1,1) + & 4945 & tl_lon1%d_value( il_iul1(1)+ji*id_rho(jp_I), & 4946 & il_iul1(2),1,1) + & 4947 & tl_lon1%d_value( il_iur1(1)+ji*id_rho(jp_I), & 4948 & il_iur1(2),1,1) ) 4949 4950 ENDIF 4951 4952 ! assume there could be little difference due to interpolation 4953 IF( ABS(dl_lon1F - dl_lon0F) > dl_delta )THEN 4954 ll_coincidence=.FALSE. 4955 CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//& 4956 & "i-direction refinement factor ("//& 4957 & TRIM(fct_str(id_rho(jp_I)))//& 4958 & ") between fine grid and coarse grid ") 4959 ENDIF 4960 ENDIF 4961 4962 ENDDO 4963 4964 ! check j-direction refinement factor 4965 DO jj=0,MIN(3,il_jmid1) 4966 4967 IF( il_ind1(2)+jj*id_rho(jp_J)+1 > tl_lat1%t_dim(2)%i_len )THEN 4968 CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& 4969 & " to check j-direction refinement factor ") 4970 EXIT 4971 ELSE 4972 IF( ll_grid0F )THEN 4973 dl_lat0F=tl_lat0F%d_value(il_ind0(1)-1, il_ind0(2)+jj-1,1,1) 4974 ELSE 4975 dl_lat0F= 0.25 * & 4976 & ( tl_lat0%d_value(il_ind0(1) , il_ind0(2)+jj ,1,1) + & 4977 & tl_lat0%d_value(il_ind0(1)-1, il_ind0(2)+jj ,1,1) + & 4978 & tl_lat0%d_value(il_ind0(1) , il_ind0(2)+jj-1,1,1) + & 4979 & tl_lat0%d_value(il_ind0(1)-1, il_ind0(2)+jj-1,1,1) ) 4980 ENDIF 4981 4982 IF( ll_grid1F )THEN 4983 dl_lat1F= tl_lat1F%d_value( il_ind1(1), & 4984 & il_ind1(2)+jj*id_rho(jp_J),1,1) 4985 ELSE 4986 dl_lat1F= 0.25 * & 4987 & ( tl_lat1%d_value( il_ill1(1), & 4988 & il_ill1(2)+jj*id_rho(jp_J),1,1) + & 4989 & tl_lat1%d_value( il_ilr1(1), & 4990 & il_ilr1(2)+jj*id_rho(jp_J),1,1) + & 4991 & tl_lat1%d_value( il_iul1(1), & 4992 & il_iul1(2)+jj*id_rho(jp_J),1,1) + & 4993 & tl_lat1%d_value( il_iur1(1), & 4994 & il_iur1(2)+jj*id_rho(jp_J),1,1) ) 4995 4996 ENDIF 4997 4998 ! assume there could be little difference due to interpolation 4999 IF( ABS(dl_lat1F - dl_lat0F) > dl_delta )THEN 5000 ll_coincidence=.FALSE. 5001 CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//& 5002 & "i-direction refinement factor ("//& 5003 & TRIM(fct_str(id_rho(jp_I)))//& 5004 & ") between fine grid and coarse grid ") 5005 ENDIF 5006 ENDIF 5007 5008 ENDDO 5009 ENDIF 4283 5010 4284 5011 ! clean … … 4851 5578 4852 5579 ! copy structure 4853 4854 4855 4856 4857 4858 4859 5580 tl_mpp=mpp_copy(td_mpp) 5581 5582 CALL logger_info("GRID GET FINE GHOST perio"//TRIM(fct_str(tl_mpp%i_perio))) 5583 IF( tl_mpp%i_perio < 0 )THEN 5584 ! compute NEMO periodicity index 5585 CALL grid_get_info(tl_mpp) 5586 ENDIF 4860 5587 4861 5588 SELECT CASE(tl_mpp%i_perio) -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/interp_linear.f90
r5617 r7339 627 627 628 628 IF( ld_even(jp_I) )THEN 629 dl_dx=1. /REAL(id_rho(jp_I)-1)629 dl_dx=1._dp/REAL(id_rho(jp_I)-1,dp) 630 630 ELSE ! odd refinement 631 dl_dx=1. /REAL(id_rho(jp_I))631 dl_dx=1._dp/REAL(id_rho(jp_I),dp) 632 632 ENDIF 633 633 634 634 IF( ld_even(jp_J) )THEN 635 dl_dy=1. /REAL(id_rho(jp_J)-1)635 dl_dy=1._dp/REAL(id_rho(jp_J)-1,dp) 636 636 ELSE ! odd refinement 637 dl_dy=1. /REAL(id_rho(jp_J))637 dl_dy=1._dp/REAL(id_rho(jp_J),dp) 638 638 ENDIF 639 639 … … 642 642 643 643 IF( ld_even(jp_J) )THEN 644 dl_y= (jj-1)*dl_dy - dl_dy*0.5644 dl_y=REAL(jj-1,dp)*dl_dy - dl_dy*0.5_dp 645 645 ELSE ! odd refinement 646 dl_y= (jj-1)*dl_dy646 dl_y=REAL(jj-1,dp)*dl_dy 647 647 ENDIF 648 648 … … 653 653 654 654 IF( ld_even(jp_I) )THEN 655 dl_x= (ji-1)*dl_dx - dl_dx*0.5655 dl_x=REAL(ji-1,dp)*dl_dx - dl_dx*0.5_dp 656 656 ELSE ! odd refinement 657 dl_x= (ji-1)*dl_dx657 dl_x=REAL(ji-1,dp)*dl_dx 658 658 ENDIF 659 659 … … 692 692 693 693 IF( ld_even )THEN 694 dl_dx=1. /REAL(id_rho-1)694 dl_dx=1._dp/REAL(id_rho-1,dp) 695 695 ELSE ! odd refinement 696 dl_dx=1. /REAL(id_rho)696 dl_dx=1._dp/REAL(id_rho,dp) 697 697 ENDIF 698 698 699 699 DO ji=1,id_rho+1 700 700 IF( ld_even )THEN 701 dl_x= (ji-1)*dl_dx - dl_dx*0.5701 dl_x=REAL(ji-1,dp)*dl_dx - dl_dx*0.5_dp 702 702 ELSE ! odd refinement 703 dl_x= (ji-1)*dl_dx703 dl_x=REAL(ji-1,dp)*dl_dx 704 704 ENDIF 705 705 -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/iom_cdf.f90
r5617 r7339 214 214 & cmode=NF90_64BIT_OFFSET,& 215 215 & ncid=td_file%i_id) 216 !NF90_WRITE, &217 216 CALL iom_cdf__check(il_status," IOM CDF CREATE: ") 218 217 … … 222 221 223 222 ELSE 223 224 224 IF( td_file%i_id /= 0 )THEN 225 225 … … 239 239 CALL iom_cdf__check(il_status," IOM CDF OPEN: ") 240 240 241 CALL logger_trace("IOM CDF OPEN "//TRIM(td_file%c_name)//" "//&242 & TRIM(fct_str(td_file%i_id)))243 241 ELSE 244 242 … … 363 361 ! Argument 364 362 TYPE(TFILE), INTENT(INOUT) :: td_file 363 ! local variable 364 TYPE(TDIM) :: tl_dim 365 365 366 366 ! loop indices 367 367 INTEGER(i4) :: ji 368 INTEGER(i4) :: ii 368 369 !---------------------------------------------------------------- 369 370 … … 374 375 375 376 IF( td_file%i_ndim > 0 )THEN 377 ii=1 376 378 DO ji = 1, td_file%i_ndim 377 379 ! read dimension information 378 td_file%t_dim(ji)=iom_cdf_read_dim( td_file, ji) 380 tl_dim=iom_cdf_read_dim( td_file, ji) 381 IF( .NOT. dim_is_dummy(tl_dim) )THEN 382 IF( ii > ip_maxdim )THEN 383 CALL logger_fatal("IOM CDF OPEN: too much dimension "//& 384 & "to be read. you should remove dummy dimension using "//& 385 & " configuration file") 386 ENDIF 387 td_file%t_dim(ii)=dim_copy(tl_dim) 388 ii=ii+1 389 ENDIF 379 390 ENDDO 380 391 … … 418 429 419 430 ! local variable 431 TYPE(TATT) :: tl_att 432 420 433 ! loop indices 421 434 INTEGER(i4) :: ji 435 INTEGER(i4) :: ii 422 436 !---------------------------------------------------------------- 423 437 … … 429 443 ALLOCATE(td_file%t_att(td_file%i_natt)) 430 444 445 ii=1 431 446 DO ji = 1, td_file%i_natt 432 447 ! read global attribute 433 td_file%t_att(ji)=iom_cdf_read_att( td_file, NF90_GLOBAL, ji) 448 tl_att=iom_cdf_read_att( td_file, NF90_GLOBAL, ji) 449 IF( .NOT. att_is_dummy(tl_att) )THEN 450 td_file%t_att(ii)=att_copy(tl_att) 451 ii=ii+1 452 ENDIF 434 453 435 454 ENDDO … … 450 469 !> @author J.Paul 451 470 !> @date November, 2013 - Initial Version 471 !> @date September, 2015 472 !> - manage useless (dummy) variable 473 !> @date January, 2016 474 !> - increment n3d for 4D variable 452 475 ! 453 476 !> @param[inout] td_file file structure … … 460 483 ! local variable 461 484 INTEGER(i4) :: il_attid 485 INTEGER(i4) :: il_nvar 486 487 TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var 462 488 463 489 ! loop indices 464 490 INTEGER(i4) :: ji 491 INTEGER(i4) :: ii 465 492 !---------------------------------------------------------------- 466 493 467 494 IF( td_file%i_nvar > 0 )THEN 495 468 496 IF(ASSOCIATED(td_file%t_var))THEN 469 497 CALL var_clean(td_file%t_var(:)) 470 498 DEALLOCATE(td_file%t_var) 471 499 ENDIF 500 501 il_nvar=td_file%i_nvar 502 ALLOCATE(tl_var(il_nvar)) 503 ii=0 504 DO ji = 1, il_nvar 505 ! read variable information 506 tl_var(ji)=iom_cdf__read_var_meta( td_file, ji) 507 IF( .NOT. var_is_dummy(tl_var(ji)) )THEN 508 ii=ii+1 509 ENDIF 510 ENDDO 511 512 ! update number of variable used 513 td_file%i_nvar=ii 514 472 515 ALLOCATE(td_file%t_var(td_file%i_nvar)) 473 516 474 DO ji = 1, td_file%i_nvar 475 ! read dimension information 476 td_file%t_var(ji)=iom_cdf__read_var_meta( td_file, ji) 477 SELECT CASE(td_file%t_var(ji)%i_ndim) 478 CASE(0) 479 td_file%i_n0d=td_file%i_n0d+1 480 CASE(1) 481 td_file%i_n1d=td_file%i_n1d+1 482 td_file%i_rhd=td_file%i_rhd+1 483 CASE(2) 484 td_file%i_n2d=td_file%i_n2d+1 485 td_file%i_rhd=td_file%i_rhd+1 486 CASE(3) 487 td_file%i_n3d=td_file%i_n3d+1 488 td_file%i_rhd=td_file%i_rhd+td_file%t_dim(3)%i_len 489 END SELECT 490 491 ! look for depth id 492 IF( INDEX(TRIM(fct_lower(td_file%t_var(ji)%c_name)),'depth')/=0 )THEN 493 IF( td_file%i_depthid == 0 )THEN 494 td_file%i_depthid=ji 495 ELSE 496 IF( td_file%i_depthid /= ji )THEN 497 CALL logger_error("IOM CDF GET FILE VAR: find more"//& 498 & " than one depth variable in file "//& 499 & TRIM(td_file%c_name) ) 517 ii=0 518 DO ji = 1, il_nvar 519 IF( .NOT. var_is_dummy(tl_var(ji)) )THEN 520 ii=ii+1 521 td_file%t_var(ii)=var_copy(tl_var(ji)) 522 SELECT CASE(td_file%t_var(ii)%i_ndim) 523 CASE(0) 524 td_file%i_n0d=td_file%i_n0d+1 525 CASE(1) 526 td_file%i_n1d=td_file%i_n1d+1 527 td_file%i_rhd=td_file%i_rhd+1 528 CASE(2) 529 td_file%i_n2d=td_file%i_n2d+1 530 td_file%i_rhd=td_file%i_rhd+1 531 CASE(3,4) 532 td_file%i_n3d=td_file%i_n3d+1 533 td_file%i_rhd=td_file%i_rhd+td_file%t_dim(3)%i_len 534 END SELECT 535 536 ! look for depth id 537 IF( INDEX(TRIM(fct_lower(td_file%t_var(ii)%c_name)),'depth')/=0 )THEN 538 IF( td_file%i_depthid == 0 )THEN 539 td_file%i_depthid=ji 540 ELSE 541 IF( td_file%i_depthid /= ji )THEN 542 CALL logger_error("IOM CDF GET FILE VAR: find more"//& 543 & " than one depth variable in file "//& 544 & TRIM(td_file%c_name) ) 545 ENDIF 500 546 ENDIF 501 547 ENDIF 502 ENDIF 503 504 ! look for time id 505 IF( INDEX(TRIM(fct_lower(td_file%t_var(ji)%c_name)),'time')/=0 )THEN 506 IF( td_file%i_timeid == 0 )THEN 507 td_file%i_timeid=ji 508 ELSE 509 il_attid=0 510 IF( ASSOCIATED(td_file%t_var(ji)%t_att) )THEN 511 il_attid=att_get_id(td_file%t_var(ji)%t_att(:),'calendar') 512 ENDIF 513 IF( il_attid /= 0 )THEN 548 549 ! look for time id 550 IF( INDEX(TRIM(fct_lower(td_file%t_var(ii)%c_name)),'time')/=0 )THEN 551 IF( td_file%i_timeid == 0 )THEN 514 552 td_file%i_timeid=ji 515 !ELSE 516 ! CALL logger_error("IOM CDF GET FILE VAR: find more "//& 517 ! & "than one time variable in file "//& 518 ! & TRIM(td_file%c_name) ) 553 ELSE 554 il_attid=0 555 IF( ASSOCIATED(td_file%t_var(ii)%t_att) )THEN 556 il_attid=att_get_id(td_file%t_var(ii)%t_att(:),'calendar') 557 ENDIF 558 IF( il_attid /= 0 )THEN 559 td_file%i_timeid=ji 560 !ELSE 561 ! CALL logger_error("IOM CDF GET FILE VAR: find more "//& 562 ! & "than one time variable in file "//& 563 ! & TRIM(td_file%c_name) ) 564 ENDIF 519 565 ENDIF 520 566 ENDIF 567 521 568 ENDIF 522 523 569 ENDDO 570 571 CALL var_clean(tl_var(:)) 572 DEALLOCATE(tl_var) 524 573 525 574 ELSE … … 605 654 ELSE 606 655 607 iom_cdf__read_dim_id%i_id=id_dimid608 609 656 CALL logger_trace( & 610 657 & " IOM CDF READ DIM: dimension "//TRIM(fct_str(id_dimid))//& … … 627 674 ENDIF 628 675 676 iom_cdf__read_dim_id%i_id=id_dimid 677 629 678 END FUNCTION iom_cdf__read_dim_id 630 679 !------------------------------------------------------------------- … … 748 797 IF( LEN(cl_value) < il_len )THEN 749 798 750 CALL logger_ error( &799 CALL logger_warn( & 751 800 & " IOM CDF READ ATT: not enough space to put "//& 752 801 & "attribute "//TRIM(cl_name) ) … … 1223 1272 !> @date September, 2014 1224 1273 !> - force to use FillValue=1.e20 if no FillValue for coordinate variable. 1274 !> @date September, 2015 1275 !> - manage useless (dummy) attribute 1225 1276 ! 1226 1277 !> @param[in] td_file file structure … … 1250 1301 1251 1302 ! loop indices 1303 INTEGER(i4) :: ji 1252 1304 !---------------------------------------------------------------- 1253 1305 ! check if file opened … … 1275 1327 & il_natt ) 1276 1328 CALL iom_cdf__check(il_status,"IOM CDF READ VAR META: ") 1329 1277 1330 !!! fill variable dimension structure 1278 tl_dim(:)=iom_cdf__read_var_dim( td_file, il_ndim, il_dimid(:) )1331 tl_dim(:)=iom_cdf__read_var_dim( td_file, il_ndim, cl_name, il_dimid(:) ) 1279 1332 1280 1333 IF( il_natt /= 0 )THEN … … 1353 1406 & tl_att(:), id_id=id_varid ) 1354 1407 1408 !! look for dummy attribute 1409 DO ji=il_natt,1,-1 1410 IF( att_is_dummy(tl_att(ji)) )THEN 1411 CALL var_del_att(iom_cdf__read_var_meta, tl_att(ji)) 1412 ENDIF 1413 ENDDO 1414 1355 1415 ! clean 1356 1416 CALL dim_clean(tl_dim(:)) … … 1373 1433 !> So the array of dimension structure of a variable is always compose of 4 1374 1434 !> dimension (use or not). 1375 ! 1435 !> 1436 !> @warn dummy dimension are not used. 1437 !> 1376 1438 !> @author J.Paul 1377 1439 !> @date November, 2013 - Initial Version 1378 1440 !> @date July, 2015 1379 1441 !> - Bug fix: use order to disorder table (see dim_init) 1442 !> @date September, 2015 1443 !> - check dummy dimension 1380 1444 !> 1381 1445 !> @param[in] td_file file structure 1382 1446 !> @param[in] id_ndim number of dimension 1447 !> @param[in] cd_name variable name 1383 1448 !> @param[in] id_dimid array of dimension id 1384 1449 !> @return array dimension structure 1385 1450 !------------------------------------------------------------------- 1386 FUNCTION iom_cdf__read_var_dim(td_file, id_ndim, id_dimid)1451 FUNCTION iom_cdf__read_var_dim(td_file, id_ndim, cd_name, id_dimid) 1387 1452 IMPLICIT NONE 1388 1453 ! Argument 1389 1454 TYPE(TFILE), INTENT(IN) :: td_file 1390 1455 INTEGER(i4), INTENT(IN) :: id_ndim 1456 CHARACTER(LEN=*) , INTENT(IN) :: cd_name 1391 1457 INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_dimid 1392 1458 … … 1401 1467 ! loop indices 1402 1468 INTEGER(i4) :: ji 1469 INTEGER(i4) :: ii 1403 1470 !---------------------------------------------------------------- 1404 1471 … … 1415 1482 CALL dim_clean(tl_dim(:)) 1416 1483 1417 ELSE IF( id_ndim > 0 .AND. id_ndim <= 4 )THEN 1418 1419 1484 ELSE IF( id_ndim > 0 )THEN 1485 1486 1487 ii=1 1420 1488 DO ji = 1, id_ndim 1421 CALL logger_debug( " IOM CDF READ VAR DIM: get variable "//& 1422 & "dimension "//TRIM(fct_str(ji)) ) 1423 1424 il_xyzt2(ji)=td_file%t_dim(id_dimid(ji))%i_xyzt2 1425 1426 ! read dimension information 1427 tl_dim(ji) = dim_init( td_file%t_dim(il_xyzt2(ji))%c_name, & 1428 & td_file%t_dim(il_xyzt2(ji))%i_len ) 1489 1490 !!! check no dummy dimension to be used 1491 IF( ANY(td_file%t_dim(:)%i_id == id_dimid(ji)) )THEN 1492 IF( ii > ip_maxdim )THEN 1493 CALL logger_error(" IOM CDF READ VAR DIM: "//& 1494 & "too much dimensions for variable "//& 1495 & TRIM(cd_name)//". check dummy configuration file.") 1496 ENDIF 1497 1498 CALL logger_debug( " IOM CDF READ VAR DIM: get variable "//& 1499 & "dimension "//TRIM(fct_str(ji)) ) 1500 1501 il_xyzt2(ii)=td_file%t_dim(id_dimid(ji))%i_xyzt2 1502 1503 ! read dimension information 1504 tl_dim(ii) = dim_init( td_file%t_dim(il_xyzt2(ii))%c_name, & 1505 & td_file%t_dim(il_xyzt2(ii))%i_len ) 1506 1507 ii=ii+1 1508 ELSE 1509 CALL logger_debug( " IOM CDF READ VAR DIM: dummy variable "//& 1510 & "dimension "//TRIM(fct_str(ji))//" not used." ) 1511 ENDIF 1429 1512 ENDDO 1430 1513 … … 1436 1519 ! clean 1437 1520 CALL dim_clean(tl_dim(:)) 1438 1439 ELSE1440 1441 CALL logger_error(" IOM CDF READ VAR DIM: can't manage "//&1442 & TRIM(fct_str(id_ndim))//" dimension(s)" )1443 1521 1444 1522 ENDIF … … 1943 2021 !> @author J.Paul 1944 2022 !> @date November, 2013 - Initial Version 2023 !> @date September, 2015 2024 !> - do not force to use zero as FillValue for any meshmask variable 1945 2025 ! 1946 2026 !> @param[inout] td_file file structure … … 1976 2056 ! check if file and variable dimension conform 1977 2057 IF( file_check_var_dim(td_file, td_var) )THEN 1978 1979 ! check variable dimension expected1980 CALL var_check_dim(td_var)1981 2058 1982 2059 ll_chg=.TRUE. … … 1998 2075 CASE('nav_lon','nav_lat', & 1999 2076 & 'glamt','glamu','glamv','glamf', & 2000 & 'gphit','gphiu','gphiv','gphif') 2077 & 'gphit','gphiu','gphiv','gphif', & 2078 & 'e1t','e1u','e1v','e1f', & 2079 & 'e2t','e2u','e2v','e2f','ff', & 2080 & 'gcost','gcosu','gcosv','gcosf', & 2081 & 'gsint','gsinu','gsinv','gsinf', & 2082 & 'mbathy','misf','isf_draft', & 2083 & 'hbatt','hbatu','hbatv','hbatf', & 2084 & 'gsigt','gsigu','gsigv','gsigf', & 2085 & 'e3t_0','e3u_0','e3v_0','e3w_0', & 2086 & 'e3f_0','gdepw_1d','gdept_1d', & 2087 & 'e3tp','e3wp','gdepw_0','rx1', & 2088 & 'gdept_0','gdepu','gdepv', & 2089 & 'hdept','hdepw','e3w_1d','e3t_1d',& 2090 & 'tmask','umask','vmask','fmask' ) 2091 ! do not change for coordinates and meshmask variables 2001 2092 END SELECT 2002 2093 ENDIF … … 2118 2209 ENDIF 2119 2210 2120 IF( tl_var%t_att(ji)%i_type == NF90_CHAR )THEN 2121 IF( TRIM(tl_var%t_att(ji)%c_value) /= '' )THEN 2122 il_status = NF90_PUT_ATT(td_file%i_id, iom_cdf__write_var_def, & 2123 & TRIM(tl_var%t_att(ji)%c_name), & 2124 & TRIM(tl_var%t_att(ji)%c_value) ) 2125 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") 2126 ENDIF 2127 ELSE 2128 SELECT CASE(tl_var%t_att(ji)%i_type) 2129 CASE(NF90_BYTE) 2130 il_status = NF90_PUT_ATT(td_file%i_id, & 2131 & iom_cdf__write_var_def, & 2132 & TRIM(tl_var%t_att(ji)%c_name), & 2133 & INT(tl_var%t_att(ji)%d_value(:),i1)) 2134 CASE(NF90_SHORT) 2135 il_status = NF90_PUT_ATT(td_file%i_id, & 2136 & iom_cdf__write_var_def, & 2137 & TRIM(tl_var%t_att(ji)%c_name), & 2138 & INT(tl_var%t_att(ji)%d_value(:),i2)) 2139 CASE(NF90_INT) 2140 il_status = NF90_PUT_ATT(td_file%i_id, & 2141 & iom_cdf__write_var_def, & 2142 & TRIM(tl_var%t_att(ji)%c_name), & 2143 & INT(tl_var%t_att(ji)%d_value(:),i4)) 2144 CASE(NF90_FLOAT) 2145 il_status = NF90_PUT_ATT(td_file%i_id, & 2146 & iom_cdf__write_var_def, & 2147 & TRIM(tl_var%t_att(ji)%c_name), & 2148 & REAL(tl_var%t_att(ji)%d_value(:),sp)) 2149 CASE(NF90_DOUBLE) 2150 il_status = NF90_PUT_ATT(td_file%i_id, & 2151 & iom_cdf__write_var_def, & 2152 & TRIM(tl_var%t_att(ji)%c_name), & 2153 & REAL(tl_var%t_att(ji)%d_value(:),dp)) 2154 END SELECT 2155 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") 2156 ENDIF 2211 SELECT CASE(tl_var%t_att(ji)%i_type) 2212 CASE(NF90_CHAR) 2213 IF( TRIM(tl_var%t_att(ji)%c_value) /= '' )THEN 2214 il_status = NF90_PUT_ATT(td_file%i_id, iom_cdf__write_var_def, & 2215 & TRIM(tl_var%t_att(ji)%c_name), & 2216 & TRIM(tl_var%t_att(ji)%c_value) ) 2217 ENDIF 2218 CASE(NF90_BYTE) 2219 il_status = NF90_PUT_ATT(td_file%i_id, & 2220 & iom_cdf__write_var_def, & 2221 & TRIM(tl_var%t_att(ji)%c_name), & 2222 & INT(tl_var%t_att(ji)%d_value(:),i1)) 2223 CASE(NF90_SHORT) 2224 il_status = NF90_PUT_ATT(td_file%i_id, & 2225 & iom_cdf__write_var_def, & 2226 & TRIM(tl_var%t_att(ji)%c_name), & 2227 & INT(tl_var%t_att(ji)%d_value(:),i2)) 2228 CASE(NF90_INT) 2229 il_status = NF90_PUT_ATT(td_file%i_id, & 2230 & iom_cdf__write_var_def, & 2231 & TRIM(tl_var%t_att(ji)%c_name), & 2232 & INT(tl_var%t_att(ji)%d_value(:),i4)) 2233 CASE(NF90_FLOAT) 2234 il_status = NF90_PUT_ATT(td_file%i_id, & 2235 & iom_cdf__write_var_def, & 2236 & TRIM(tl_var%t_att(ji)%c_name), & 2237 & REAL(tl_var%t_att(ji)%d_value(:),sp)) 2238 CASE(NF90_DOUBLE) 2239 il_status = NF90_PUT_ATT(td_file%i_id, & 2240 & iom_cdf__write_var_def, & 2241 & TRIM(tl_var%t_att(ji)%c_name), & 2242 & REAL(tl_var%t_att(ji)%d_value(:),dp)) 2243 END SELECT 2244 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") 2245 2157 2246 ENDDO 2158 2247 … … 2200 2289 & (td_var%d_value(:,:,:,:)-td_var%d_ofs)/td_var%d_scf 2201 2290 END WHERE 2202 2291 2203 2292 jj=0 2204 2293 DO ji = 1, ip_maxdim … … 2226 2315 2227 2316 ! put value 2228 CALL logger_ trace( &2317 CALL logger_debug( & 2229 2318 & "IOM CDF WRITE VAR VALUE: put "//TRIM(td_var%c_name)//" value "//& 2230 2319 & "in file "//TRIM(td_file%c_name)) 2231 2320 2232 2321 il_status = NF90_PUT_VAR( td_file%i_id, td_var%i_id, dl_value(:,:,:,:)) 2233 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR VALUE: ") 2322 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR VALUE ("//& 2323 & TRIM(td_var%c_name)//") :" ) 2234 2324 2235 2325 DEALLOCATE( dl_value ) -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/iom_dom.f90
r5617 r7339 234 234 CALL logger_error( & 235 235 & " IOM DOM READ VAR: there is no variable with "//& 236 & "name or standard name "//TRIM(cd_name)//&236 & "name or standard name "//TRIM(cd_name)//& 237 237 & " in processor/file "//TRIM(td_mpp%t_proc(1)%c_name)) 238 238 ENDIF -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/iom_mpp.f90
r5617 r7339 415 415 ELSE 416 416 417 CALL logger_ error( &417 CALL logger_fatal( & 418 418 & " IOM MPP READ VAR: there is no variable with "//& 419 419 & "name or standard name "//TRIM(cd_name)//& … … 648 648 DO ji=1, td_mpp%i_nproc 649 649 IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN 650 !CALL file_del_att(td_mpp%t_proc(ji), 'periodicity')651 !CALL file_del_att(td_mpp%t_proc(ji), 'ew_overlap')652 653 650 CALL iom_write_file(td_mpp%t_proc(ji), cd_dimorder) 654 651 ELSE -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/iom_rstdimg.f90
r5617 r7339 395 395 !> @author J.Paul 396 396 !> @date November, 2013 - Initial Version 397 ! 397 !> @date January, 2016 398 !> - mismatch with "halo" indices 399 !> 398 400 !> @param[inout] td_file file structure 399 401 !------------------------------------------------------------------- … … 494 496 ENDIF 495 497 496 tl_att=att_init( " DOMAIN_position_first", (/il_impp(il_area), il_jmpp(il_area)/))498 tl_att=att_init( "SUBDOMAIN_I_left_bottom_indices", il_impp(:) ) 497 499 CALL file_move_att(td_file, tl_att) 498 499 tl_att=att_init( "DOMAIN_position_last", (/il_lci(il_area), il_lcj(il_area)/)) 500 tl_att=att_init( "SUBDOMAIN_J_left_bottom_indices", il_jmpp(:) ) 500 501 CALL file_move_att(td_file, tl_att) 501 502 502 tl_att=att_init( " DOMAIN_halo_size_start", (/il_ldi(il_area), il_ldj(il_area)/))503 tl_att=att_init( "SUBDOMAIN_I_dimensions", il_lci(:)) 503 504 CALL file_move_att(td_file, tl_att) 504 505 tl_att=att_init( "DOMAIN_halo_size_end", (/il_lei(il_area), il_lej(il_area)/)) 505 tl_att=att_init( "SUBDOMAIN_J_dimensions", il_lcj(:)) 506 506 CALL file_move_att(td_file, tl_att) 507 507 508 tl_att=att_init( " DOMAIN_I_position_first", il_impp(:))508 tl_att=att_init( "SUBDOMAIN_I_first_indoor_indices", il_ldi(:)) 509 509 CALL file_move_att(td_file, tl_att) 510 tl_att=att_init( " DOMAIN_J_position_first", il_jmpp(:))510 tl_att=att_init( "SUBDOMAIN_J_first_indoor_indices", il_ldj(:)) 511 511 CALL file_move_att(td_file, tl_att) 512 512 513 tl_att=att_init( " DOMAIN_I_position_last", il_lci(:))513 tl_att=att_init( "SUBDOMAIN_I_last_indoor_indices", il_lei(:)) 514 514 CALL file_move_att(td_file, tl_att) 515 tl_att=att_init( "DOMAIN_J_position_last", il_lcj(:) ) 516 CALL file_move_att(td_file, tl_att) 517 518 tl_att=att_init( "DOMAIN_I_halo_size_start", il_ldi(:) ) 519 CALL file_move_att(td_file, tl_att) 520 tl_att=att_init( "DOMAIN_J_halo_size_start", il_ldj(:) ) 521 CALL file_move_att(td_file, tl_att) 522 523 tl_att=att_init( "DOMAIN_I_halo_size_end", il_lei(:) ) 524 CALL file_move_att(td_file, tl_att) 525 tl_att=att_init( "DOMAIN_J_halo_size_end", il_lej(:) ) 515 tl_att=att_init( "SUBDOMAIN_J_last_indoor_indices", il_lej(:)) 526 516 CALL file_move_att(td_file, tl_att) 527 517 … … 1038 1028 !> @author J.Paul 1039 1029 !> @date November, 2013 - Initial Version 1030 !> @date February, 2016 1031 !> - use temporary array to read value from file 1040 1032 ! 1041 1033 !> @param[in] td_file file structure … … 1059 1051 INTEGER(i4), DIMENSION(ip_maxdim) :: il_count 1060 1052 1053 REAL(dp), DIMENSION(:,:,:) , ALLOCATABLE :: dl_tmp 1061 1054 REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value 1062 1055 … … 1142 1135 IF( ALL(td_var%t_dim(1:3)%l_use) )THEN 1143 1136 ! 3D variable (X,Y,Z) 1137 ALLOCATE(dl_tmp( td_var%t_dim(1)%i_len, & 1138 & td_var%t_dim(2)%i_len, & 1139 & td_var%t_dim(4)%i_len) ) 1144 1140 DO ji=1,td_var%t_dim(3)%i_len 1145 1141 READ(td_file%i_id, IOSTAT=il_status, REC=td_var%i_rec +ji-1) & 1146 & dl_ value(:,:,ji,:)1142 & dl_tmp(:,:,:) 1147 1143 CALL fct_err(il_status) 1148 1144 IF( il_status /= 0 )THEN … … 1150 1146 & TRIM(td_var%c_name)) 1151 1147 ENDIF 1148 dl_value(:,:,ji,:)=dl_tmp(:,:,:) 1152 1149 ENDDO 1150 DEALLOCATE(dl_tmp) 1153 1151 ELSEIF( ALL(td_var%t_dim(1:2)%l_use) )THEN 1154 1152 ! 2D variable (X,Y) … … 1427 1425 !> @author J.Paul 1428 1426 !> @date November, 2013 - Initial Version 1429 ! 1427 !> @date January, 2016 1428 !> - mismatch with "halo" indices 1429 !> 1430 1430 !> @param[inout] td_file file structure 1431 1431 !------------------------------------------------------------------- … … 1542 1542 & il_lei(il_nproc), il_lej(il_nproc) ) 1543 1543 1544 ! get domain first poistion1545 il_ind=att_get_index( td_file%t_att, " DOMAIN_I_position_first" )1544 ! get left bottom indices 1545 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_I_left_bottom_indices" ) 1546 1546 il_impp(:) = 0 1547 1547 IF( il_ind /= 0 )THEN … … 1549 1549 ENDIF 1550 1550 1551 il_ind=att_get_index( td_file%t_att, " DOMAIN_J_position_first" )1551 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_J_left_bottom_indices" ) 1552 1552 il_jmpp(:) = 0 1553 1553 IF( il_ind /= 0 )THEN … … 1555 1555 ENDIF 1556 1556 1557 ! check domain first poistion1557 ! check left bottom indices 1558 1558 IF( ANY(il_impp(:)==0) .OR. ANY(il_jmpp(:)==0) )THEN 1559 CALL logger_warn("WRITE FILE: no data for domain first position")1560 ENDIF 1561 1562 ! get domain last poistion1563 il_ind=att_get_index( td_file%t_att, " DOMAIN_I_position_last" )1559 CALL logger_warn("WRITE FILE: no data for subdomain left bottom indices") 1560 ENDIF 1561 1562 ! get subdomain dimensions 1563 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_I_dimensions" ) 1564 1564 il_lci(:) = 0 1565 1565 IF( il_ind /= 0 )THEN … … 1567 1567 ENDIF 1568 1568 1569 il_ind=att_get_index( td_file%t_att, " DOMAIN_J_position_last" )1569 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_J_dimensions" ) 1570 1570 il_lcj(:) = 0 1571 1571 IF( il_ind /= 0 )THEN … … 1573 1573 ENDIF 1574 1574 1575 ! check domain last poistion1575 ! check subdomain dimension 1576 1576 IF( ANY(il_lci(:)==0) .OR. ANY(il_lcj(:)==0) )THEN 1577 CALL logger_warn("WRITE FILE: no data for domain last position")1578 ENDIF 1579 1580 ! get halo size start1581 il_ind=att_get_index( td_file%t_att, " DOMAIN_I_halo_size_start" )1577 CALL logger_warn("WRITE FILE: no data for subdomain dimensions") 1578 ENDIF 1579 1580 ! get first indoor indices 1581 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_I_first_indoor_indices" ) 1582 1582 il_ldi(:) = 0 1583 1583 IF( il_ind /= 0 )THEN … … 1585 1585 ENDIF 1586 1586 1587 il_ind=att_get_index( td_file%t_att, " DOMAIN_J_halo_size_start" )1587 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_J_first_indoor_indices" ) 1588 1588 il_ldj(:) = 0 1589 1589 IF( il_ind /= 0 )THEN … … 1591 1591 ENDIF 1592 1592 1593 ! check halo size start1593 ! check first indoor indices 1594 1594 IF( ANY(il_ldi(:)==0) .OR. ANY(il_ldj(:)==0) )THEN 1595 CALL logger_warn("WRITE FILE: no data for halo size start")1596 ENDIF 1597 1598 ! get halo size end1599 il_ind=att_get_index( td_file%t_att, " DOMAIN_I_halo_size_end" )1595 CALL logger_warn("WRITE FILE: no data for subdomain first indoor indices") 1596 ENDIF 1597 1598 ! get last indoor indices 1599 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_I_last_indoor_indices" ) 1600 1600 il_lei(:) = 0 1601 1601 IF( il_ind /= 0 )THEN … … 1603 1603 ENDIF 1604 1604 1605 il_ind=att_get_index( td_file%t_att, " DOMAIN_J_halo_size_end" )1605 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_J_last_indoor_indices" ) 1606 1606 il_lej(:) = 0 1607 1607 IF( il_ind /= 0 )THEN … … 1609 1609 ENDIF 1610 1610 1611 ! check halo size end1611 ! check last indoor indices 1612 1612 IF( ANY(il_lei(:)==0) .OR. ANY(il_lej(:)==0) )THEN 1613 CALL logger_warn("WRITE FILE: no data for halo size end")1613 CALL logger_warn("WRITE FILE: no data for subdomain last indoor indices") 1614 1614 ENDIF 1615 1615 -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/logger.f90
r5617 r7339 6 6 ! 7 7 ! DESCRIPTION: 8 !> @brief This module create logger file and allow to fill it depending of verbosity.8 !> @brief This module manage log file. 9 9 !> @details 10 !> This module create log file and fill it depending of verbosity. 11 !> 10 12 !> verbosity could be choosen between : 11 13 !> - trace : Most detailed information. … … 17 19 !> - error : Other runtime errors or unexpected conditions. 18 20 !> - fatal : Severe errors that cause premature termination. 19 !> default verbosity is warning20 21 !> - none : to not create and write any information in logger file.<br /> 21 ! 22 !> @warn in this case only FATAL ERROR will be detected.<br /> 23 !> 24 !> @note default verbosity is warning 25 !> 22 26 !> If total number of error exceeded maximum number 23 27 !> authorized, program stop. … … 35 39 !> @code 36 40 !> CALL logger_close() 41 !> @endcode 42 !> 43 !> to clean logger file:<br/> 44 !> @code 45 !> CALL logger_clean() 37 46 !> @endcode 38 47 !> … … 104 113 !> CALL logger_footer() 105 114 !> CALL logger_close() 115 !> CALL logger_clean() 106 116 !> @endcode 107 117 !> … … 116 126 !> CALL logger_footer() 117 127 !> CALL logger_close() 128 !> CALL logger_clean() 118 129 !> @endcode 119 130 ! … … 125 136 !> - check verbosity validity 126 137 !> - add 'none' verbosity level to not used logger file 138 !> @date January, 2016 139 !> - add logger_clean subroutine 127 140 !> 128 141 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 144 157 PUBLIC :: logger_open !< create a log file with given verbosity 145 158 PUBLIC :: logger_close !< close log file 159 PUBLIC :: logger_clean !< clean log structure 146 160 PUBLIC :: logger_header !< write header on log file 147 161 PUBLIC :: logger_footer !< write footer on log file … … 273 287 IMPLICIT NONE 274 288 ! local variable 275 INTEGER(i4) :: il_status276 !---------------------------------------------------------------- 277 IF( tm_logger%l_use )THEN 278 IF( tm_logger%i_id /= 0 )THEN 279 tm_logger%i_id = 0289 INTEGER(i4) :: il_status 290 !---------------------------------------------------------------- 291 IF( tm_logger%l_use )THEN 292 IF( tm_logger%i_id /= 0 )THEN 293 !tm_logger%i_id = 0 280 294 CLOSE( tm_logger%i_id, & 281 295 & IOSTAT=il_status) … … 289 303 290 304 END SUBROUTINE logger_close 305 !------------------------------------------------------------------- 306 !> @brief This subroutine clean a log structure. 307 !> 308 !> @author J.Paul 309 !> @date January, 2016 - Initial Version 310 !------------------------------------------------------------------- 311 SUBROUTINE logger_clean() 312 IMPLICIT NONE 313 ! local variable 314 TYPE(TLOGGER) :: tl_logger 315 !---------------------------------------------------------------- 316 tm_logger = tl_logger 317 318 END SUBROUTINE logger_clean 291 319 !------------------------------------------------------------------- 292 320 !> @brief This subroutine flushing output into log file. … … 537 565 IF( tm_logger%l_use )THEN 538 566 IF( tm_logger%i_id /= 0 )THEN 539 IF( TRIM(tm_logger%c_verb) /= 'none' )THEN 540 ! increment the error number 541 tm_logger%i_nerror=tm_logger%i_nerror+1 542 ENDIF 567 ! increment the error number 568 tm_logger%i_nerror=tm_logger%i_nerror+1 543 569 544 570 IF( INDEX(TRIM(tm_logger%c_verb),'error')/=0 )THEN … … 571 597 !> @author J.Paul 572 598 !> @date November, 2013 - Initial Version 599 !> @date September, 2015 600 !> - stop program for FATAL ERROR if verbosity is none 573 601 ! 574 602 !> @param[in] cd_msg message to write … … 598 626 CALL logger_fatal('you must have create logger to use logger_fatal') 599 627 ENDIF 628 ELSE 629 PRINT *,"FATAL ERROR :"//TRIM(cd_msg) 630 STOP 600 631 ENDIF 601 632 END SUBROUTINE logger_fatal -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/math.f90
r5617 r7339 1224 1224 1225 1225 CASE('K') 1226 1227 ALLOCATE( dl_value(il_shape(1),il_shape(2),3) ) 1226 1228 ! compute derivative in k-direction 1227 1229 DO jk=1,il_shape(3) … … 1266 1268 ENDIF 1267 1269 1268 WHERE( dl_value(:,:, 1269 & dl_value(:,:, 1270 & dl_value(:,:, 1270 WHERE( dl_value(:,:,2) /= dd_fill .AND. & ! jk 1271 & dl_value(:,:,3) /= dd_fill .AND. & ! jk+1 1272 & dl_value(:,:,1) /= dd_fill ) ! jk-1 1271 1273 1272 1274 math_deriv_3D(:,:,jk)=& -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/merge_bathy.f90
r5609 r7339 9 9 !> @file 10 10 !> @brief 11 !> This program merge bathymetry file at boundaries.11 !> This program merges bathymetry file at boundaries. 12 12 !> 13 13 !> @details 14 14 !> @section sec1 method 15 !> Coarse grid Bathymetry is interpolated on fine grid. 15 !> Coarse grid Bathymetry is interpolated on fine grid 16 !> (nearest interpolation method is used). 16 17 !> Then fine Bathymetry and refined coarse bathymetry are merged at boundaries.<br/> 17 18 !> @f[BathyFine= Weight * BathyCoarse + (1-Weight)*BathyFine@f] … … 31 32 !> you could find a template of the namelist in templates directory. 32 33 !> 33 !> merge_bathy.nam co mprise 8namelists:34 !> merge_bathy.nam contains 7 namelists: 34 35 !> - logger namelist (namlog) 35 36 !> - config namelist (namcfg) 36 37 !> - coarse grid namelist (namcrs) 37 38 !> - fine grid namelist (namfin) 38 ! >- variable namelist (namvar)39 ! - variable namelist (namvar) 39 40 !> - nesting namelist (namnst) 40 41 !> - boundary namelist (nambdy) 41 42 !> - output namelist (namout) 42 43 !> 43 !> @note44 !> All namelists have to be in file merge_bathy.nam,45 !> however variables of those namelists are all optional.46 !>47 44 !> * _logger namelist (namlog)_: 48 45 !> - cn_logfile : logger filename … … 52 49 !> 53 50 !> * _config namelist (namcfg)_: 54 !> - cn_varcfg : variable configuration file (see ./SIREN/cfg/variable.cfg) 51 !> - cn_varcfg : variable configuration file 52 !> (see ./SIREN/cfg/variable.cfg) 53 !> - cn_dumcfg : useless (dummy) configuration file, for useless 54 !> dimension or variable (see ./SIREN/cfg/dummy.cfg). 55 55 !> 56 56 !> * _coarse grid namelist (namcrs)_: … … 63 63 !> - in_perio1 : NEMO periodicity index 64 64 !> 65 ! >* _variable namelist (namvar)_:66 ! >- cn_varinfo : list of variable and extra information about request(s)67 ! >to be used (separated by ',').<br/>68 ! >each elements of *cn_varinfo* is a string character.<br/>69 ! >it is composed of the variable name follow by ':',70 ! >then request(s) to be used on this variable.<br/>71 ! >request could be:72 ! >- int = interpolation method73 ! >74 ! >requests must be separated by ';'.<br/>75 ! >order of requests does not matter.<br/>76 ! >77 ! >informations about available method could be find in78 ! >@ref interp modules.<br/>79 ! >Example: 'bathymetry: int=cubic'80 ! >@note81 ! >If you do not specify a method which is required,82 ! >default one is apply.83 ! >@warning84 ! >variable name must be __Bathymetry__ here.65 ! * _variable namelist (namvar)_: 66 ! - cn_varinfo : list of variable and extra information about request(s) 67 ! to be used (separated by ',').<br/> 68 ! each elements of *cn_varinfo* is a string character.<br/> 69 ! it is composed of the variable name follow by ':', 70 ! then request(s) to be used on this variable.<br/> 71 ! request could be: 72 ! - int = interpolation method 73 ! 74 ! requests must be separated by ';'.<br/> 75 ! order of requests does not matter.<br/> 76 ! 77 ! informations about available method could be find in 78 ! @ref interp modules.<br/> 79 ! Example: 'bathymetry: int=cubic' 80 ! @note 81 ! If you do not specify a method which is required, 82 ! default one is apply. 83 ! @warning 84 ! variable name must be __Bathymetry__ here. 85 85 !> 86 86 !> * _nesting namelist (namnst)_: … … 128 128 !> - extrapolate all land points 129 129 !> - add attributes with boundary string character (as in namelist) 130 !> @date September, 2015 131 !> - manage useless (dummy) variable, attributes, and dimension 130 132 !> 131 133 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 207 209 ! namcfg 208 210 CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' 211 CHARACTER(LEN=lc) :: cn_dumcfg = 'dummy.cfg' 209 212 210 213 ! namcrs … … 216 219 INTEGER(i4) :: in_perio1 = -1 217 220 218 ! namvar219 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = ''221 ! ! namvar 222 ! CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' 220 223 221 224 ! namnst … … 244 247 245 248 NAMELIST /namcfg/ & !< config namelist 246 & cn_varcfg !< variable configuration file 249 & cn_varcfg, & !< variable configuration file 250 & cn_dumcfg !< dummy configuration file 247 251 248 252 NAMELIST /namcrs/ & !< coarse grid namelist … … 254 258 & in_perio1 !< periodicity index 255 259 256 NAMELIST /namvar/ & !< variable namelist257 & cn_varinfo !< list of variable and interpolation258 !< method to be used.259 !< (ex: 'votemper|linear','vosaline|cubic' )260 ! NAMELIST /namvar/ & !< variable namelist 261 ! & cn_varinfo !< list of variable and interpolation 262 ! !< method to be used. 263 ! !< (ex: 'votemper|linear','vosaline|cubic' ) 260 264 261 265 NAMELIST /namnst/ & !< nesting namelist … … 315 319 CALL var_def_extra(TRIM(cn_varcfg)) 316 320 321 ! get dummy variable 322 CALL var_get_dummy(TRIM(cn_dumcfg)) 323 ! get dummy dimension 324 CALL dim_get_dummy(TRIM(cn_dumcfg)) 325 ! get dummy attribute 326 CALL att_get_dummy(TRIM(cn_dumcfg)) 327 317 328 READ( il_fileid, NML = namcrs ) 318 329 READ( il_fileid, NML = namfin ) 319 READ( il_fileid, NML = namvar )320 ! add user change in extra information321 CALL var_chg_extra(cn_varinfo)330 ! READ( il_fileid, NML = namvar ) 331 ! ! add user change in extra information 332 ! CALL var_chg_extra(cn_varinfo) 322 333 323 334 READ( il_fileid, NML = namnst ) … … 630 641 !> @param[inout] dd_weight array of weight 631 642 !> @param[in] dd_fill fillValue 643 !> 644 !> @todo improve boundary weight function 632 645 !------------------------------------------------------------------- 633 646 SUBROUTINE merge_bathy_get_boundary( td_bathy0, td_bathy1, td_bdy, & … … 690 703 il_jmax1=td_bdy%t_seg(jl)%i_index 691 704 705 ! do not used grid point to compute 706 ! boundaries indices (cf create_boundary) 707 ! as Bathymetry always on T point 708 692 709 CASE('south') 693 710 … … 703 720 il_jmin1=td_bdy%t_seg(jl)%i_first 704 721 il_jmax1=td_bdy%t_seg(jl)%i_last 722 723 ! do not used grid point to compute 724 ! boundaries indices (cf create_boundary) 725 ! as Bathymetry always on T point 705 726 706 727 CASE('west') … … 777 798 tl_var0=iom_dom_read_var(tl_bathy0,'Bathymetry',tl_dom0) 778 799 800 ! force to use nearest interpolation 801 tl_var0%c_interp(1)='nearest' 802 779 803 ! close mpp files 780 804 CALL iom_dom_close(tl_bathy0) … … 814 838 CASE('north') 815 839 840 ! ! npoint coarse 841 ! il_width=td_bdy%t_seg(jl)%i_width-id_npoint 842 ! ! compute "distance" 843 ! dl_tmp1d(:)=(/(ji,ji=il_width-1,1,-1),(0,ji=1,id_npoint)/) 844 ! ! compute weight on segment 845 ! dl_tmp1d(:)= 0.5 + 0.5*COS( (dp_pi*dl_tmp1d(:)) / & 846 ! & (il_width) ) 847 816 848 ! compute "distance" 817 dl_tmp1d(:)=(/(ji-1,ji=td_bdy%t_seg(jl)%i_width ,1,-1)/)849 dl_tmp1d(:)=(/(ji-1,ji=td_bdy%t_seg(jl)%i_width-1,1,-1),0/) 818 850 819 851 ! compute weight on segment … … 831 863 832 864 ! compute "distance" 833 dl_tmp1d(:)=(/ (ji-1,ji=1,td_bdy%t_seg(jl)%i_width)/)865 dl_tmp1d(:)=(/0,(ji-1,ji=1,td_bdy%t_seg(jl)%i_width-1)/) 834 866 835 867 ! compute weight on segment … … 847 879 848 880 ! compute "distance" 849 dl_tmp1d(:)=(/(ji-1,ji=td_bdy%t_seg(jl)%i_width ,1,-1)/)881 dl_tmp1d(:)=(/(ji-1,ji=td_bdy%t_seg(jl)%i_width-1,1,-1),0/) 850 882 851 883 ! compute weight on segment … … 863 895 864 896 ! compute "distance" 865 dl_tmp1d(:)=(/ (ji-1,ji=1,td_bdy%t_seg(jl)%i_width)/)897 dl_tmp1d(:)=(/0,(ji-1,ji=1,td_bdy%t_seg(jl)%i_width-1)/) 866 898 867 899 ! compute weight on segment -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/mpp.f90
r5617 r7339 196 196 ! REVISION HISTORY: 197 197 !> @date November, 2013 - Initial Version 198 !> @date November, 2014 - Fix memory leaks bug 198 !> @date November, 2014 199 !> - Fix memory leaks bug 200 !> @date October, 2015 201 !> - improve way to compute domain layout 202 !> @date January, 2016 203 !> - allow to print layout file (use lm_layout, hard coded) 204 !> - add mpp__compute_halo and mpp__read_halo 199 205 ! 200 206 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 214 220 215 221 ! type and variable 216 PUBLIC :: TMPP !< mpp structure 222 PUBLIC :: TMPP !< mpp structure 223 PRIVATE :: TLAY !< domain layout structure 217 224 218 225 ! function and subroutine … … 239 246 PUBLIC :: mpp_get_proc_size !< get processor domain size 240 247 241 PRIVATE :: mpp__add_proc ! add one proc strucutre in mpp structure 248 PRIVATE :: mpp__add_proc ! add proc strucutre in mpp structure 249 PRIVATE :: mpp__add_proc_unit ! add one proc strucutre in mpp structure 242 250 PRIVATE :: mpp__del_proc ! delete one proc strucutre in mpp structure 243 251 PRIVATE :: mpp__del_proc_id ! delete one proc strucutre in mpp structure, given procesor id 244 252 PRIVATE :: mpp__del_proc_str ! delete one proc strucutre in mpp structure, given procesor file structure 245 253 PRIVATE :: mpp__move_proc ! overwrite proc strucutre in mpp structure 246 PRIVATE :: mpp__compute ! compute domain decomposition 247 PRIVATE :: mpp__del_land ! remove land sub domain from domain decomposition 254 PRIVATE :: mpp__create_layout ! create mpp structure using domain layout 248 255 PRIVATE :: mpp__optimiz ! compute optimum domain decomposition 249 PRIVATE :: mpp__land_proc ! check if processor is a land processor250 256 PRIVATE :: mpp__check_dim ! check mpp structure dimension with proc or variable dimension 251 257 PRIVATE :: mpp__check_proc_dim ! check if processor and mpp structure use same dimension … … 267 273 PRIVATE :: mpp__clean_unit ! clean mpp strcuture 268 274 PRIVATE :: mpp__clean_arr ! clean array of mpp strcuture 275 PRIVATE :: mpp__compute_halo ! compute subdomain indices defined with halo 276 PRIVATE :: mpp__read_halo ! read subdomain indices defined with halo 277 278 PRIVATE :: layout__init ! initialise domain layout structure 279 PRIVATE :: layout__copy ! clean domain layout structure 280 PRIVATE :: layout__clean ! copy domain layout structure 269 281 270 282 TYPE TMPP !< mpp structure 271 272 283 ! general 273 284 CHARACTER(LEN=lc) :: c_name = '' !< base name … … 284 295 285 296 CHARACTER(LEN=lc) :: c_type = '' !< type of the files (cdf, cdf4, dimg) 286 CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, overlap, nooverlap)297 CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, noextra, nooverlap) 287 298 288 299 INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in mpp … … 290 301 291 302 TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp 292 293 303 END TYPE 304 305 TYPE TLAY !< domain layout structure 306 INTEGER(i4) :: i_niproc = 0 !< number of processors following i 307 INTEGER(i4) :: i_njproc = 0 !< number of processors following j 308 INTEGER(i4) :: i_nland = 0 !< number of land processors 309 INTEGER(i4) :: i_nsea = 0 !< number of sea processors 310 INTEGER(i4) :: i_mean = 0 !< mean sea point per proc 311 INTEGER(i4) :: i_min = 0 !< min sea point per proc 312 INTEGER(i4) :: i_max = 0 !< max sea point per proc 313 INTEGER(i4), DIMENSION(:,:), POINTER :: i_msk => NULL() !< sea/land processor mask 314 INTEGER(i4), DIMENSION(:,:), POINTER :: i_impp => NULL() !< i-indexes for mpp-subdomain left bottom 315 INTEGER(i4), DIMENSION(:,:), POINTER :: i_jmpp => NULL() !< j-indexes for mpp-subdomain left bottom 316 INTEGER(i4), DIMENSION(:,:), POINTER :: i_lci => NULL() !< i-dimensions of subdomain 317 INTEGER(i4), DIMENSION(:,:), POINTER :: i_lcj => NULL() !< j-dimensions of subdomain 318 END TYPE 319 320 ! module variable 321 INTEGER(i4) :: im_iumout = 44 322 LOGICAL :: lm_layout =.FALSE. 294 323 295 324 INTERFACE mpp_get_use 296 325 MODULE PROCEDURE mpp__get_use_unit 297 326 END INTERFACE mpp_get_use 327 328 INTERFACE mpp__add_proc 329 MODULE PROCEDURE mpp__add_proc_unit 330 END INTERFACE mpp__add_proc 298 331 299 332 INTERFACE mpp_clean … … 560 593 ALLOCATE( il_lci(td_mpp%i_niproc,td_mpp%i_njproc) ) 561 594 ALLOCATE( il_lcj(td_mpp%i_niproc,td_mpp%i_njproc) ) 595 il_proc(:,:)=-1 596 il_lci(:,:) =-1 597 il_lcj(:,:) =-1 562 598 563 599 DO jk=1,td_mpp%i_nproc 564 600 ji=td_mpp%t_proc(jk)%i_iind 565 601 jj=td_mpp%t_proc(jk)%i_jind 566 il_proc(ji,jj)=jk 602 il_proc(ji,jj)=jk-1 567 603 il_lci(ji,jj)=td_mpp%t_proc(jk)%i_lci 568 604 il_lcj(ji,jj)=td_mpp%t_proc(jk)%i_lcj … … 594 630 ENDIF 595 631 596 597 632 9400 FORMAT(' ***',20('*************',a3)) 598 633 9403 FORMAT(' * ',20(' * ',a3)) … … 615 650 !> @author J.Paul 616 651 !> @date November, 2013 - Initial version 652 !> @date September, 2015 653 !> - allow to define dimension with array of dimension structure 654 !> @date January, 2016 655 !> - use RESULT to rename output 656 !> - mismatch with "halo" indices 617 657 ! 618 658 !> @param[in] cd_file file name of one file composing mpp domain … … 627 667 !> @param[in] id_perio NEMO periodicity index 628 668 !> @param[in] id_pivot NEMO pivot point index F(0),T(1) 669 !> @param[in] td_dim array of dimension structure 629 670 !> @return mpp structure 630 671 !------------------------------------------------------------------- 631 TYPE(TMPP) FUNCTION mpp__init_mask(cd_file, id_mask, & 632 & id_niproc, id_njproc, id_nproc,& 633 & id_preci, id_precj, & 634 cd_type, id_ew, id_perio, id_pivot) 672 FUNCTION mpp__init_mask(cd_file, id_mask, & 673 & id_niproc, id_njproc, id_nproc, & 674 & id_preci, id_precj, & 675 & cd_type, id_ew, id_perio, id_pivot, & 676 & td_dim ) & 677 & RESULT(td_mpp) 635 678 IMPLICIT NONE 636 679 ! Argument 637 CHARACTER(LEN=*), INTENT(IN) :: cd_file 638 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 639 INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc 640 INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc 641 INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc 642 INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci 643 INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj 644 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type 645 INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew 646 INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio 647 INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot 680 CHARACTER(LEN=*), INTENT(IN) :: cd_file 681 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 682 INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc 683 INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc 684 INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc 685 INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci 686 INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj 687 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type 688 INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew 689 INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio 690 INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot 691 TYPE(TDIM) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: td_dim 692 693 ! function 694 TYPE(TMPP) :: td_mpp 648 695 649 696 ! local variable 650 CHARACTER(LEN=lc) :: cl_type 651 652 INTEGER(i4) , DIMENSION(2) :: il_shape 653 654 TYPE(TDIM) :: tl_dim 655 656 TYPE(TATT) :: tl_att 697 CHARACTER(LEN=lc) :: cl_type 698 699 INTEGER(i4) , DIMENSION(2) :: il_shape 700 701 TYPE(TDIM) :: tl_dim 702 703 TYPE(TATT) :: tl_att 704 705 TYPE(TLAY) :: tl_lay 706 657 707 ! loop indices 658 708 INTEGER(i4) :: ji … … 660 710 661 711 ! clean mpp 662 CALL mpp_clean( mpp__init_mask)712 CALL mpp_clean(td_mpp) 663 713 664 714 ! check type … … 669 719 SELECT CASE(TRIM(cd_type)) 670 720 CASE('cdf') 671 mpp__init_mask%c_type='cdf'721 td_mpp%c_type='cdf' 672 722 CASE('dimg') 673 mpp__init_mask%c_type='dimg'723 td_mpp%c_type='dimg' 674 724 CASE DEFAULT 675 725 CALL logger_warn( "MPP INIT: type "//TRIM(cd_type)//& 676 726 & " unknown. type dimg will be used for mpp "//& 677 & TRIM( mpp__init_mask%c_name) )678 mpp__init_mask%c_type='dimg'727 & TRIM(td_mpp%c_name) ) 728 td_mpp%c_type='dimg' 679 729 END SELECT 680 730 ELSE 681 mpp__init_mask%c_type=TRIM(file_get_type(cd_file))731 td_mpp%c_type=TRIM(file_get_type(cd_file)) 682 732 ENDIF 683 733 684 734 ! get mpp name 685 mpp__init_mask%c_name=TRIM(file_rename(cd_file))735 td_mpp%c_name=TRIM(file_rename(cd_file)) 686 736 687 737 ! get global domain dimension 688 738 il_shape(:)=SHAPE(id_mask) 689 739 690 tl_dim=dim_init('X',il_shape(1)) 691 CALL mpp_add_dim(mpp__init_mask, tl_dim) 692 693 tl_dim=dim_init('Y',il_shape(2)) 694 CALL mpp_add_dim(mpp__init_mask, tl_dim) 695 696 ! clean 697 CALL dim_clean(tl_dim) 740 IF( PRESENT(td_dim) )THEN 741 DO ji=1,ip_maxdim 742 IF( td_dim(ji)%l_use )THEN 743 CALL mpp_add_dim(td_mpp, td_dim(ji)) 744 ENDIF 745 ENDDO 746 ELSE 747 tl_dim=dim_init('X',il_shape(1)) 748 CALL mpp_add_dim(td_mpp, tl_dim) 749 750 tl_dim=dim_init('Y',il_shape(2)) 751 CALL mpp_add_dim(td_mpp, tl_dim) 752 753 ! clean 754 CALL dim_clean(tl_dim) 755 ENDIF 698 756 699 757 IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_njproc))) .OR. & … … 703 761 ELSE 704 762 ! get number of processors following I and J 705 IF( PRESENT(id_niproc) ) mpp__init_mask%i_niproc=id_niproc706 IF( PRESENT(id_njproc) ) mpp__init_mask%i_njproc=id_njproc763 IF( PRESENT(id_niproc) ) td_mpp%i_niproc=id_niproc 764 IF( PRESENT(id_njproc) ) td_mpp%i_njproc=id_njproc 707 765 ENDIF 708 766 709 767 ! get maximum number of processors to be used 710 IF( PRESENT(id_nproc) ) mpp__init_mask%i_nproc = id_nproc768 IF( PRESENT(id_nproc) ) td_mpp%i_nproc = id_nproc 711 769 712 770 ! get overlap region length 713 IF( PRESENT(id_preci) ) mpp__init_mask%i_preci= id_preci714 IF( PRESENT(id_precj) ) mpp__init_mask%i_precj= id_precj771 IF( PRESENT(id_preci) ) td_mpp%i_preci= id_preci 772 IF( PRESENT(id_precj) ) td_mpp%i_precj= id_precj 715 773 716 774 ! east-west overlap 717 IF( PRESENT(id_ew) ) mpp__init_mask%i_ew= id_ew775 IF( PRESENT(id_ew) ) td_mpp%i_ew= id_ew 718 776 ! NEMO periodicity 719 IF( PRESENT(id_perio) ) mpp__init_mask%i_perio= id_perio720 IF( PRESENT(id_pivot) ) mpp__init_mask%i_pivot= id_pivot721 722 IF( mpp__init_mask%i_nproc /= 0 .AND. &723 & mpp__init_mask%i_niproc /= 0 .AND. &724 & mpp__init_mask%i_njproc /= 0 .AND. &725 & mpp__init_mask%i_nproc > &726 & mpp__init_mask%i_niproc * mpp__init_mask%i_njproc )THEN777 IF( PRESENT(id_perio) ) td_mpp%i_perio= id_perio 778 IF( PRESENT(id_pivot) ) td_mpp%i_pivot= id_pivot 779 780 IF( td_mpp%i_nproc /= 0 .AND. & 781 & td_mpp%i_niproc /= 0 .AND. & 782 & td_mpp%i_njproc /= 0 .AND. & 783 & td_mpp%i_nproc > & 784 & td_mpp%i_niproc * td_mpp%i_njproc )THEN 727 785 728 786 CALL logger_error("MPP INIT: invalid domain decomposition ") 729 787 CALL logger_debug("MPP INIT: "// & 730 & TRIM(fct_str( mpp__init_mask%i_nproc))//" > "//&731 & TRIM(fct_str( mpp__init_mask%i_niproc))//" x "//&732 & TRIM(fct_str( mpp__init_mask%i_njproc)) )788 & TRIM(fct_str(td_mpp%i_nproc))//" > "//& 789 & TRIM(fct_str(td_mpp%i_niproc))//" x "//& 790 & TRIM(fct_str(td_mpp%i_njproc)) ) 733 791 734 792 ELSE 735 736 IF( mpp__init_mask%i_niproc /= 0 .AND. & 737 & mpp__init_mask%i_njproc /= 0 )THEN 738 ! compute domain decomposition 739 CALL mpp__compute( mpp__init_mask ) 740 ! remove land sub domain 741 CALL mpp__del_land( mpp__init_mask, id_mask ) 742 ELSEIF( mpp__init_mask%i_nproc /= 0 )THEN 793 IF( lm_layout )THEN 794 OPEN(im_iumout,FILE='processor.layout') 795 WRITE(im_iumout,*) 796 WRITE(im_iumout,*) ' optimisation de la partition' 797 WRITE(im_iumout,*) ' ----------------------------' 798 WRITE(im_iumout,*) 799 ENDIF 800 801 IF( td_mpp%i_niproc /= 0 .AND. & 802 & td_mpp%i_njproc /= 0 )THEN 803 ! compute domain layout 804 tl_lay=layout__init( td_mpp, id_mask, td_mpp%i_niproc, td_mpp%i_njproc ) 805 ! create mpp domain layout 806 CALL mpp__create_layout( td_mpp, tl_lay ) 807 ! clean 808 CALL layout__clean( tl_lay ) 809 ELSEIF( td_mpp%i_nproc /= 0 )THEN 743 810 ! optimiz 744 CALL mpp__optimiz( mpp__init_mask, id_mask)811 CALL mpp__optimiz( td_mpp, id_mask, td_mpp%i_nproc ) 745 812 746 813 ELSE 747 814 CALL logger_warn("MPP INIT: number of processor to be used "//& 748 815 & "not specify. force to one.") 749 mpp__init_mask%i_nproc = 1750 816 ! optimiz 751 CALL mpp__optimiz( mpp__init_mask, id_mask)817 CALL mpp__optimiz( td_mpp, id_mask, 1 ) 752 818 ENDIF 819 820 753 821 CALL logger_info("MPP INIT: domain decoposition : "//& 754 & 'niproc('//TRIM(fct_str( mpp__init_mask%i_niproc))//') * '//&755 & 'njproc('//TRIM(fct_str( mpp__init_mask%i_njproc))//') = '//&756 & 'nproc('//TRIM(fct_str( mpp__init_mask%i_nproc))//')' )822 & 'niproc('//TRIM(fct_str(td_mpp%i_niproc))//') * '//& 823 & 'njproc('//TRIM(fct_str(td_mpp%i_njproc))//') = '//& 824 & 'nproc('//TRIM(fct_str(td_mpp%i_nproc))//')' ) 757 825 758 826 ! get domain type 759 CALL mpp_get_dom( mpp__init_mask)760 761 DO ji=1, mpp__init_mask%i_nproc827 CALL mpp_get_dom( td_mpp ) 828 829 DO ji=1,td_mpp%i_nproc 762 830 763 831 ! get processor size 764 il_shape(:)=mpp_get_proc_size( mpp__init_mask, ji )832 il_shape(:)=mpp_get_proc_size( td_mpp, ji ) 765 833 766 834 tl_dim=dim_init('X',il_shape(1)) 767 CALL file_move_dim( mpp__init_mask%t_proc(ji), tl_dim)835 CALL file_move_dim(td_mpp%t_proc(ji), tl_dim) 768 836 769 837 tl_dim=dim_init('Y',il_shape(2)) 770 CALL file_move_dim(mpp__init_mask%t_proc(ji), tl_dim) 771 838 CALL file_move_dim(td_mpp%t_proc(ji), tl_dim) 839 840 IF( PRESENT(td_dim) )THEN 841 IF( td_dim(jp_K)%l_use )THEN 842 CALL file_move_dim(td_mpp%t_proc(ji), td_dim(jp_K)) 843 ENDIF 844 IF( td_dim(jp_L)%l_use )THEN 845 CALL file_move_dim(td_mpp%t_proc(ji), td_dim(jp_L)) 846 ENDIF 847 ENDIF 772 848 ! add type 773 mpp__init_mask%t_proc(ji)%c_type=TRIM(mpp__init_mask%c_type)849 td_mpp%t_proc(ji)%c_type=TRIM(td_mpp%c_type) 774 850 775 851 ! clean 776 852 CALL dim_clean(tl_dim) 853 777 854 ENDDO 778 855 779 856 ! add global attribute 780 tl_att=att_init("DOMAIN_number_total",mpp__init_mask%i_nproc) 781 CALL mpp_add_att(mpp__init_mask, tl_att) 782 783 tl_att=att_init("DOMAIN_I_number_total",mpp__init_mask%i_niproc) 784 CALL mpp_add_att(mpp__init_mask, tl_att) 785 786 tl_att=att_init("DOMAIN_J_number_total",mpp__init_mask%i_njproc) 787 CALL mpp_add_att(mpp__init_mask, tl_att) 788 789 tl_att=att_init("DOMAIN_size_global",mpp__init_mask%t_dim(1:2)%i_len) 790 CALL mpp_add_att(mpp__init_mask, tl_att) 791 792 tl_att=att_init( "DOMAIN_I_position_first", & 793 & mpp__init_mask%t_proc(:)%i_impp ) 794 CALL mpp_add_att(mpp__init_mask, tl_att) 795 796 tl_att=att_init( "DOMAIN_J_position_first", & 797 & mpp__init_mask%t_proc(:)%i_jmpp ) 798 CALL mpp_add_att(mpp__init_mask, tl_att) 799 800 tl_att=att_init( "DOMAIN_I_position_last", & 801 & mpp__init_mask%t_proc(:)%i_lci ) 802 CALL mpp_add_att(mpp__init_mask, tl_att) 803 804 tl_att=att_init( "DOMAIN_J_position_last", & 805 & mpp__init_mask%t_proc(:)%i_lcj ) 806 CALL mpp_add_att(mpp__init_mask, tl_att) 807 808 tl_att=att_init( "DOMAIN_I_halo_size_start", & 809 & mpp__init_mask%t_proc(:)%i_ldi ) 810 CALL mpp_add_att(mpp__init_mask, tl_att) 811 812 tl_att=att_init( "DOMAIN_J_halo_size_start", & 813 & mpp__init_mask%t_proc(:)%i_ldj ) 814 CALL mpp_add_att(mpp__init_mask, tl_att) 815 816 tl_att=att_init( "DOMAIN_I_halo_size_end", & 817 & mpp__init_mask%t_proc(:)%i_lei ) 818 CALL mpp_add_att(mpp__init_mask, tl_att) 819 820 tl_att=att_init( "DOMAIN_J_halo_size_end", & 821 & mpp__init_mask%t_proc(:)%i_lej ) 822 CALL mpp_add_att(mpp__init_mask, tl_att) 823 824 ! clean 825 CALL att_clean(tl_att) 857 tl_att=att_init("DOMAIN_number_total",td_mpp%i_nproc) 858 CALL mpp_add_att(td_mpp, tl_att) 859 860 tl_att=att_init("DOMAIN_LOCAL",TRIM(td_mpp%c_dom)) 861 CALL mpp_add_att(td_mpp, tl_att) 862 863 tl_att=att_init("DOMAIN_I_number_total",td_mpp%i_niproc) 864 CALL mpp_add_att(td_mpp, tl_att) 865 866 tl_att=att_init("DOMAIN_J_number_total",td_mpp%i_njproc) 867 CALL mpp_add_att(td_mpp, tl_att) 868 869 tl_att=att_init("DOMAIN_size_global",td_mpp%t_dim(1:2)%i_len) 870 CALL mpp_add_att(td_mpp, tl_att) 871 872 CALL mpp__compute_halo(td_mpp) 826 873 ENDIF 827 874 … … 880 927 il_mask(:,:,:)=var_get_mask(td_var) 881 928 929 CALL logger_info("MPP INIT: mask compute from variable "//& 930 & TRIM(td_var%c_name)) 882 931 mpp__init_var=mpp_init( cd_file, il_mask(:,:,1), & 883 932 & id_niproc, id_njproc, id_nproc,& … … 907 956 !> - DOMAIN_halo_size_end 908 957 !> or the file is assume to be no mpp file. 909 !>910 !>911 958 !> 912 959 !> @author J.Paul 913 960 !> @date November, 2013 - Initial Version 961 !> @date January, 2016 962 !> - mismatch with "halo" indices, use mpp__compute_halo 914 963 ! 915 964 !> @param[in] td_file file strcuture … … 929 978 930 979 ! local variable 931 TYPE(TMPP) :: tl_mpp 932 933 TYPE(TFILE) :: tl_file 934 935 TYPE(TDIM) :: tl_dim 936 937 TYPE(TATT) :: tl_att 938 939 INTEGER(i4) :: il_nproc 940 INTEGER(i4) :: il_attid 941 980 INTEGER(i4) :: il_nproc 981 INTEGER(i4) :: il_attid 942 982 INTEGER(i4), DIMENSION(2) :: il_shape 983 984 TYPE(TDIM) :: tl_dim 985 986 TYPE(TATT) :: tl_att 987 988 TYPE(TFILE) :: tl_file 989 990 TYPE(TMPP) :: tl_mpp 991 943 992 ! loop indices 944 993 INTEGER(i4) :: ji … … 956 1005 ! open file 957 1006 CALL iom_open(tl_file) 958 959 1007 ! read first file domain decomposition 960 1008 tl_mpp=mpp__init_file_cdf(tl_file) … … 1029 1077 CALL mpp_move_att(mpp__init_file, tl_att) 1030 1078 1031 tl_att=att_init( "DOMAIN_I_position_first", mpp__init_file%t_proc(:)%i_impp ) 1032 CALL mpp_move_att(mpp__init_file, tl_att) 1033 1034 tl_att=att_init( "DOMAIN_J_position_first", mpp__init_file%t_proc(:)%i_jmpp ) 1035 CALL mpp_move_att(mpp__init_file, tl_att) 1036 1037 tl_att=att_init( "DOMAIN_I_position_last", mpp__init_file%t_proc(:)%i_lci ) 1038 CALL mpp_move_att(mpp__init_file, tl_att) 1039 1040 tl_att=att_init( "DOMAIN_J_position_last", mpp__init_file%t_proc(:)%i_lcj ) 1041 CALL mpp_move_att(mpp__init_file, tl_att) 1042 1043 tl_att=att_init( "DOMAIN_I_halo_size_start", mpp__init_file%t_proc(:)%i_ldi ) 1044 CALL mpp_move_att(mpp__init_file, tl_att) 1045 1046 tl_att=att_init( "DOMAIN_J_halo_size_start", mpp__init_file%t_proc(:)%i_ldj ) 1047 CALL mpp_move_att(mpp__init_file, tl_att) 1048 1049 tl_att=att_init( "DOMAIN_I_halo_size_end", mpp__init_file%t_proc(:)%i_lei ) 1050 CALL mpp_move_att(mpp__init_file, tl_att) 1051 1052 tl_att=att_init( "DOMAIN_J_halo_size_end", mpp__init_file%t_proc(:)%i_lej ) 1053 CALL mpp_move_att(mpp__init_file, tl_att) 1054 1079 CALL mpp__compute_halo(mpp__init_file) 1080 1055 1081 ! clean 1056 1082 CALL mpp_clean(tl_mpp) … … 1130 1156 !> @author J.Paul 1131 1157 !> @date November, 2013 - Initial Version 1132 !> @date July, 2015 - add only use dimension in MPP structure 1158 !> @date July, 2015 1159 !> - add only use dimension in MPP structure 1160 !> @date January, 2016 1161 !> - mismatch with "halo" indices, use mpp__read_halo 1133 1162 !> 1134 1163 !> @param[in] td_file file strcuture … … 1218 1247 tl_proc%t_dim(:)=dim_copy(td_file%t_dim(:)) 1219 1248 1220 ! DOMAIN_position_first 1221 il_attid = 0 1222 IF( ASSOCIATED(td_file%t_att) )THEN 1223 il_attid=att_get_id( td_file%t_att, "DOMAIN_position_first" ) 1224 ENDIF 1225 IF( il_attid /= 0 )THEN 1226 tl_proc%i_impp = INT(td_file%t_att(il_attid)%d_value(1)) 1227 tl_proc%i_jmpp = INT(td_file%t_att(il_attid)%d_value(2)) 1228 ELSE 1229 tl_proc%i_impp = 1 1230 tl_proc%i_jmpp = 1 1231 ENDIF 1232 1233 ! DOMAIN_position_last 1234 il_attid = 0 1235 IF( ASSOCIATED(td_file%t_att) )THEN 1236 il_attid=att_get_id( td_file%t_att, "DOMAIN_position_last" ) 1237 ENDIF 1238 IF( il_attid /= 0 )THEN 1239 tl_proc%i_lci = INT(td_file%t_att(il_attid)%d_value(1)) + tl_proc%i_impp 1240 tl_proc%i_lcj = INT(td_file%t_att(il_attid)%d_value(2)) + tl_proc%i_jmpp 1241 ELSE 1242 tl_proc%i_lci = mpp__init_file_cdf%t_dim(1)%i_len 1243 tl_proc%i_lcj = mpp__init_file_cdf%t_dim(2)%i_len 1244 ENDIF 1245 1246 ! DOMAIN_halo_size_start 1247 il_attid = 0 1248 IF( ASSOCIATED(td_file%t_att) )THEN 1249 il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_start" ) 1250 ENDIF 1251 IF( il_attid /= 0 )THEN 1252 tl_proc%i_ldi = INT(td_file%t_att(il_attid)%d_value(1)) 1253 tl_proc%i_ldj = INT(td_file%t_att(il_attid)%d_value(2)) 1254 ELSE 1255 tl_proc%i_ldi = 1 1256 tl_proc%i_ldj = 1 1257 ENDIF 1258 1259 ! DOMAIN_halo_size_end 1260 il_attid = 0 1261 IF( ASSOCIATED(td_file%t_att) )THEN 1262 il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_end" ) 1263 ENDIF 1264 IF( il_attid /= 0 )THEN 1265 tl_proc%i_lei = INT(td_file%t_att(il_attid)%d_value(1)) 1266 tl_proc%i_lej = INT(td_file%t_att(il_attid)%d_value(2)) 1267 ELSE 1268 tl_proc%i_lei = mpp__init_file_cdf%t_dim(1)%i_len 1269 tl_proc%i_lej = mpp__init_file_cdf%t_dim(2)%i_len 1270 ENDIF 1249 CALL mpp__read_halo(tl_proc, mpp__init_file_cdf%t_dim(:) ) 1271 1250 1272 1251 ! add attributes … … 1278 1257 CALL file_move_att(tl_proc, tl_att) 1279 1258 1280 tl_att=att_init( "DOMAIN_position_first", &1281 & (/tl_proc%i_impp, tl_proc%i_jmpp /) )1282 CALL file_move_att(tl_proc, tl_att)1283 1284 tl_att=att_init( "DOMAIN_position_last", &1285 & (/tl_proc%i_lci, tl_proc%i_lcj /) )1286 CALL file_move_att(tl_proc, tl_att)1287 1288 tl_att=att_init( "DOMAIN_halo_size_start", &1289 & (/tl_proc%i_ldi, tl_proc%i_ldj /) )1290 CALL file_move_att(tl_proc, tl_att)1291 1292 tl_att=att_init( "DOMAIN_halo_size_end", &1293 & (/tl_proc%i_lei, tl_proc%i_lej /) )1294 CALL file_move_att(tl_proc, tl_att)1295 1296 1259 ! add processor to mpp structure 1297 1260 CALL mpp__add_proc(mpp__init_file_cdf, tl_proc) … … 1299 1262 ! clean 1300 1263 CALL file_clean(tl_proc) 1264 CALL dim_clean(tl_dim) 1301 1265 CALL att_clean(tl_att) 1302 1266 ENDIF … … 1307 1271 & " do not exist") 1308 1272 1309 ENDIF 1273 ENDIF 1274 1310 1275 END FUNCTION mpp__init_file_cdf 1311 1276 !------------------------------------------------------------------- … … 1317 1282 !> @author J.Paul 1318 1283 !> @date November, 2013 - Initial Version 1319 ! 1284 !> @date January, 2016 1285 !> - mismatch with "halo" indices, use mpp__compute_halo 1286 !> 1320 1287 !> @param[in] td_file file strcuture 1321 1288 !> @return mpp structure … … 1336 1303 INTEGER(i4) :: il_pni, il_pnj, il_pnij ! domain decomposition 1337 1304 INTEGER(i4) :: il_area ! domain index 1305 1306 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lci 1307 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldi 1308 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lei 1309 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_impp 1310 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lcj 1311 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldj 1312 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lej 1313 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jmpp 1338 1314 1339 1315 LOGICAL :: ll_exist … … 1389 1365 ALLOCATE( mpp__init_file_rstdimg%t_proc(il_pnij) , stat=il_status ) 1390 1366 1367 ALLOCATE(il_lci (il_pnij)) 1368 ALLOCATE(il_lcj (il_pnij)) 1369 ALLOCATE(il_ldi (il_pnij)) 1370 ALLOCATE(il_ldj (il_pnij)) 1371 ALLOCATE(il_lei (il_pnij)) 1372 ALLOCATE(il_lej (il_pnij)) 1373 ALLOCATE(il_impp(il_pnij)) 1374 ALLOCATE(il_jmpp(il_pnij)) 1375 1391 1376 tl_proc=file_copy(td_file) 1392 1377 ! remove dimension from file … … 1411 1396 & il_area, & 1412 1397 & il_iglo, il_jglo, & 1413 & mpp__init_file_rstdimg%t_proc(:)%i_lci, &1414 & mpp__init_file_rstdimg%t_proc(:)%i_lcj, &1415 & mpp__init_file_rstdimg%t_proc(:)%i_ldi, &1416 & mpp__init_file_rstdimg%t_proc(:)%i_ldj, &1417 & mpp__init_file_rstdimg%t_proc(:)%i_lei, &1418 & mpp__init_file_rstdimg%t_proc(:)%i_lej, &1419 & mpp__init_file_rstdimg%t_proc(:)%i_impp, &1420 & mpp__init_file_rstdimg%t_proc(:)%i_jmpp1398 & il_lci(1:il_pnij), & 1399 & il_lcj(1:il_pnij), & 1400 & il_ldi(1:il_pnij), & 1401 & il_ldj(1:il_pnij), & 1402 & il_lei(1:il_pnij), & 1403 & il_lej(1:il_pnij), & 1404 & il_impp(1:il_pnij), & 1405 & il_jmpp(1:il_pnij) 1421 1406 CALL fct_err(il_status) 1422 1407 IF( il_status /= 0 )THEN … … 1424 1409 & TRIM(td_file%c_name)) 1425 1410 ENDIF 1411 1412 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lci = il_lci (1:il_pnij) 1413 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lcj = il_lcj (1:il_pnij) 1414 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_ldi = il_ldi (1:il_pnij) 1415 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_ldj = il_ldj (1:il_pnij) 1416 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lei = il_lei (1:il_pnij) 1417 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lej = il_lej (1:il_pnij) 1418 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_impp= il_impp(1:il_pnij) 1419 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_jmpp= il_jmpp(1:il_pnij) 1420 1421 DEALLOCATE(il_lci) 1422 DEALLOCATE(il_lcj) 1423 DEALLOCATE(il_ldi) 1424 DEALLOCATE(il_ldj) 1425 DEALLOCATE(il_lei) 1426 DEALLOCATE(il_lej) 1427 DEALLOCATE(il_impp) 1428 DEALLOCATE(il_jmpp) 1426 1429 1427 1430 ! global domain size … … 1435 1438 1436 1439 DO ji=1,mpp__init_file_rstdimg%i_nproc 1440 1437 1441 ! get file name 1438 1442 cl_file = file_rename(td_file%c_name,ji) … … 1445 1449 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att) 1446 1450 1447 tl_att=att_init( "DOMAIN_position_first", &1448 & (/mpp__init_file_rstdimg%t_proc(ji)%i_impp, &1449 & mpp__init_file_rstdimg%t_proc(ji)%i_jmpp /) )1450 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)1451 1452 tl_att=att_init( "DOMAIN_position_last", &1453 & (/mpp__init_file_rstdimg%t_proc(ji)%i_lci, &1454 & mpp__init_file_rstdimg%t_proc(ji)%i_lcj /) )1455 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)1456 1457 tl_att=att_init( "DOMAIN_halo_size_start", &1458 & (/mpp__init_file_rstdimg%t_proc(ji)%i_ldi, &1459 & mpp__init_file_rstdimg%t_proc(ji)%i_ldj /) )1460 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)1461 1462 tl_att=att_init( "DOMAIN_halo_size_end", &1463 & (/mpp__init_file_rstdimg%t_proc(ji)%i_lei, &1464 & mpp__init_file_rstdimg%t_proc(ji)%i_lej /) )1465 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)1466 1451 ENDDO 1467 1452 … … 1486 1471 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1487 1472 1488 tl_att=att_init( "DOMAIN_I_position_first", & 1489 & mpp__init_file_rstdimg%t_proc(:)%i_impp ) 1490 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1491 1492 tl_att=att_init( "DOMAIN_J_position_first", & 1493 & mpp__init_file_rstdimg%t_proc(:)%i_jmpp ) 1494 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1495 1496 tl_att=att_init( "DOMAIN_I_position_last", & 1497 & mpp__init_file_rstdimg%t_proc(:)%i_lci ) 1498 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1499 1500 tl_att=att_init( "DOMAIN_J_position_last", & 1501 & mpp__init_file_rstdimg%t_proc(:)%i_lcj ) 1502 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1503 1504 tl_att=att_init( "DOMAIN_I_halo_size_start", & 1505 & mpp__init_file_rstdimg%t_proc(:)%i_ldi ) 1506 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1507 1508 tl_att=att_init( "DOMAIN_J_halo_size_start", & 1509 & mpp__init_file_rstdimg%t_proc(:)%i_ldj ) 1510 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1511 1512 tl_att=att_init( "DOMAIN_I_halo_size_end", & 1513 & mpp__init_file_rstdimg%t_proc(:)%i_lei ) 1514 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1515 1516 tl_att=att_init( "DOMAIN_J_halo_size_end", & 1517 & mpp__init_file_rstdimg%t_proc(:)%i_lej ) 1518 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1473 CALL mpp_get_dom( mpp__init_file_rstdimg ) 1474 1475 CALL mpp__compute_halo( mpp__init_file_rstdimg ) 1519 1476 1520 1477 ! clean … … 1598 1555 ! Argument 1599 1556 TYPE(TMPP), INTENT(INOUT) :: td_mpp 1600 TYPE(TVAR), INTENT(IN ):: td_var1557 TYPE(TVAR), INTENT(INOUT) :: td_var 1601 1558 1602 1559 ! local variable … … 1646 1603 ! check used dimension 1647 1604 IF( mpp__check_dim(td_mpp, td_var) )THEN 1605 1606 ! check variable dimension expected 1607 CALL var_check_dim(td_var) 1648 1608 1649 1609 ! update dimension if need be … … 1915 1875 TYPE(TVAR) :: tl_var 1916 1876 !---------------------------------------------------------------- 1917 ! copy variabl e1877 ! copy variablie 1918 1878 tl_var=var_copy(td_var) 1919 1879 … … 1942 1902 !> - check proc type 1943 1903 !------------------------------------------------------------------- 1944 SUBROUTINE mpp__add_proc ( td_mpp, td_proc )1904 SUBROUTINE mpp__add_proc_unit( td_mpp, td_proc ) 1945 1905 IMPLICIT NONE 1946 1906 ! Argument … … 1957 1917 CHARACTER(LEN=lc) :: cl_name 1958 1918 !---------------------------------------------------------------- 1919 1920 ! ALLOCATE(tl_proc(1)) 1921 ! tl_proc(1)=file_copy(td_proc) 1922 ! 1923 ! CALL mpp__add_proc(td_mpp, tl_proc(:)) 1924 ! 1925 ! CALL file_clean(tl_proc(:)) 1926 ! DEALLOCATE(tl_proc) 1959 1927 1960 1928 ! check file name … … 2056 2024 2057 2025 ENDIF 2058 END SUBROUTINE mpp__add_proc 2026 2027 END SUBROUTINE mpp__add_proc_unit 2059 2028 !------------------------------------------------------------------- 2060 2029 !> @brief … … 2575 2544 !------------------------------------------------------------------- 2576 2545 !> @brief 2577 !> This subroutine compute domain decomposition for niproc and njproc 2578 !> processors following I and J. 2579 !> 2546 !> This function initialise domain layout 2547 !> 2580 2548 !> @detail 2581 !> To do so, it need to know : 2582 !> - global domain dimension 2583 !> - overlap region length 2584 !> - number of processors following I and J 2549 !> Domain layout is first compute, with domain dimension, overlap between subdomain, 2550 !> and the number of processors following I and J. 2551 !> Then the number of sea/land processors is compute with mask 2585 2552 ! 2586 2553 !> @author J.Paul 2587 !> @date November, 2013 - Initial version 2554 !> @date October, 2015 - Initial version 2555 ! 2556 !> @param[in] td_mpp mpp strcuture 2557 !> @param[in] id_mask sub domain mask (sea=1, land=0) 2558 !> @pâram[in] id_niproc number of processors following I 2559 !> @pâram[in] id_njproc number of processors following J 2560 !> @return domain layout structure 2561 !------------------------------------------------------------------- 2562 FUNCTION layout__init( td_mpp, id_mask, id_niproc, id_njproc ) RESULT(td_lay) 2563 IMPLICIT NONE 2564 ! Argument 2565 TYPE(TMPP) , INTENT(IN) :: td_mpp 2566 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 2567 INTEGER(i4) , INTENT(IN) :: id_niproc 2568 INTEGER(i4) , INTENT(IN) :: id_njproc 2569 2570 ! function 2571 TYPE(TLAY) :: td_lay 2572 2573 ! local variable 2574 INTEGER(i4) :: ii1, ii2 2575 INTEGER(i4) :: ij1, ij2 2576 2577 INTEGER(i4) :: il_ldi 2578 INTEGER(i4) :: il_ldj 2579 INTEGER(i4) :: il_lei 2580 INTEGER(i4) :: il_lej 2581 2582 INTEGER(i4) :: il_isize !< i-direction maximum sub domain size 2583 INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size 2584 INTEGER(i4) :: il_resti !< 2585 INTEGER(i4) :: il_restj !< 2586 2587 ! loop indices 2588 INTEGER(i4) :: ji 2589 INTEGER(i4) :: jj 2590 !---------------------------------------------------------------- 2591 2592 ! intialise 2593 td_lay%i_niproc=id_niproc 2594 td_lay%i_njproc=id_njproc 2595 2596 CALL logger_info( "MPP COMPUTE LAYOUT: compute domain layout with "//& 2597 & TRIM(fct_str(td_lay%i_niproc))//" x "//& 2598 & TRIM(fct_str(td_lay%i_njproc))//" processors") 2599 2600 ! maximum size of sub domain 2601 il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (td_lay%i_niproc-1))/ & 2602 & td_lay%i_niproc) + 2*td_mpp%i_preci 2603 il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (td_lay%i_njproc-1))/ & 2604 & td_lay%i_njproc) + 2*td_mpp%i_precj 2605 2606 il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, td_lay%i_niproc) 2607 il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, td_lay%i_njproc) 2608 IF( il_resti == 0 ) il_resti = td_lay%i_niproc 2609 IF( il_restj == 0 ) il_restj = td_lay%i_njproc 2610 2611 ! compute dimension of each sub domain 2612 ALLOCATE( td_lay%i_lci(td_lay%i_niproc,td_lay%i_njproc) ) 2613 ALLOCATE( td_lay%i_lcj(td_lay%i_niproc,td_lay%i_njproc) ) 2614 2615 td_lay%i_lci( 1 : il_resti , : ) = il_isize 2616 td_lay%i_lci( il_resti+1 : td_lay%i_niproc, : ) = il_isize-1 2617 2618 td_lay%i_lcj( : , 1 : il_restj ) = il_jsize 2619 td_lay%i_lcj( : , il_restj+1 : td_lay%i_njproc) = il_jsize-1 2620 2621 ! compute first index of each sub domain 2622 ALLOCATE( td_lay%i_impp(td_lay%i_niproc,td_lay%i_njproc) ) 2623 ALLOCATE( td_lay%i_jmpp(td_lay%i_niproc,td_lay%i_njproc) ) 2624 2625 td_lay%i_impp(:,:)=1 2626 td_lay%i_jmpp(:,:)=1 2627 2628 IF( td_lay%i_niproc > 1 )THEN 2629 DO jj=1,td_lay%i_njproc 2630 DO ji=2,td_lay%i_niproc 2631 td_lay%i_impp(ji,jj) = td_lay%i_impp(ji-1,jj) + & 2632 & td_lay%i_lci (ji-1,jj) - 2*td_mpp%i_preci 2633 ENDDO 2634 ENDDO 2635 ENDIF 2636 2637 IF( td_lay%i_njproc > 1 )THEN 2638 DO jj=2,td_lay%i_njproc 2639 DO ji=1,td_lay%i_niproc 2640 td_lay%i_jmpp(ji,jj) = td_lay%i_jmpp(ji,jj-1) + & 2641 & td_lay%i_lcj (ji,jj-1) - 2*td_mpp%i_precj 2642 ENDDO 2643 ENDDO 2644 ENDIF 2645 2646 ALLOCATE(td_lay%i_msk(td_lay%i_niproc,td_lay%i_njproc)) 2647 td_lay%i_msk(:,:)=0 2648 ! init number of sea/land proc 2649 td_lay%i_nsea=0 2650 td_lay%i_nland=td_lay%i_njproc*td_lay%i_niproc 2651 2652 ! check if processor is land or sea 2653 DO jj = 1,td_lay%i_njproc 2654 DO ji = 1,td_lay%i_niproc 2655 2656 ! compute first and last indoor indices 2657 ! west boundary 2658 IF( ji == 1 )THEN 2659 il_ldi = 1 2660 ELSE 2661 il_ldi = 1 + td_mpp%i_preci 2662 ENDIF 2663 2664 ! south boundary 2665 IF( jj == 1 )THEN 2666 il_ldj = 1 2667 ELSE 2668 il_ldj = 1 + td_mpp%i_precj 2669 ENDIF 2670 2671 ! east boundary 2672 IF( ji == td_mpp%i_niproc )THEN 2673 il_lei = td_lay%i_lci(ji,jj) 2674 ELSE 2675 il_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci 2676 ENDIF 2677 2678 ! north boundary 2679 IF( jj == td_mpp%i_njproc )THEN 2680 il_lej = td_lay%i_lcj(ji,jj) 2681 ELSE 2682 il_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj 2683 ENDIF 2684 2685 ii1=td_lay%i_impp(ji,jj) + il_ldi - 1 2686 ii2=td_lay%i_impp(ji,jj) + il_lei - 1 2687 2688 ij1=td_lay%i_jmpp(ji,jj) + il_ldj - 1 2689 ij2=td_lay%i_jmpp(ji,jj) + il_lej - 1 2690 2691 td_lay%i_msk(ji,jj)=SUM( id_mask(ii1:ii2,ij1:ij2) ) 2692 IF( td_lay%i_msk(ji,jj) > 0 )THEN ! sea 2693 td_lay%i_nsea =td_lay%i_nsea +1 2694 td_lay%i_nland=td_lay%i_nland-1 2695 ENDIF 2696 2697 ENDDO 2698 ENDDO 2699 2700 CALL logger_info( "MPP COMPUTE LAYOUT: sea proc "//TRIM(fct_str(td_lay%i_nsea))) 2701 CALL logger_info( "MPP COMPUTE LAYOUT: land proc "//TRIM(fct_str(td_lay%i_nland))) 2702 CALL logger_info( "MPP COMPUTE LAYOUT: sum "//TRIM(fct_str( SUM(td_lay%i_msk(:,:))))) 2703 2704 td_lay%i_mean= SUM(td_lay%i_msk(:,:)) / td_lay%i_nsea 2705 td_lay%i_min = MINVAL(td_lay%i_msk(:,:),td_lay%i_msk(:,:)/=0) 2706 td_lay%i_max = MAXVAL(td_lay%i_msk(:,:)) 2707 2708 IF( lm_layout )THEN 2709 ! print info 2710 WRITE(im_iumout,*) ' ' 2711 WRITE(im_iumout,*) " jpni=",td_lay%i_niproc ," jpnj=",td_lay%i_njproc 2712 WRITE(im_iumout,*) " jpi= ",il_isize," jpj= ",il_jsize 2713 WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj 2714 2715 2716 WRITE(im_iumout,*) ' nombre de processeurs ',td_lay%i_niproc*td_lay%i_njproc 2717 WRITE(im_iumout,*) ' nombre de processeurs mer ',td_lay%i_nsea 2718 WRITE(im_iumout,*) ' nombre de processeurs terre ',td_lay%i_nland 2719 WRITE(im_iumout,*) ' moyenne de recouvrement ',td_lay%i_mean 2720 WRITE(im_iumout,*) ' minimum de recouvrement ',td_lay%i_min 2721 WRITE(im_iumout,*) ' maximum de recouvrement ',td_lay%i_max 2722 ENDIF 2723 2724 END FUNCTION layout__init 2725 !------------------------------------------------------------------- 2726 !> @brief 2727 !> This subroutine clean domain layout strcuture. 2728 !> 2729 !> @author J.Paul 2730 !> @date October, 2015 - Initial version 2731 !> 2732 !> @param[inout] td_lay domain layout strcuture 2733 !------------------------------------------------------------------- 2734 SUBROUTINE layout__clean( td_lay ) 2735 IMPLICIT NONE 2736 ! Argument 2737 TYPE(TLAY), INTENT(INOUT) :: td_lay 2738 !---------------------------------------------------------------- 2739 2740 IF( ASSOCIATED(td_lay%i_msk) )THEN 2741 DEALLOCATE(td_lay%i_msk) 2742 ENDIF 2743 IF( ASSOCIATED(td_lay%i_impp) )THEN 2744 DEALLOCATE(td_lay%i_impp) 2745 ENDIF 2746 IF( ASSOCIATED(td_lay%i_jmpp) )THEN 2747 DEALLOCATE(td_lay%i_jmpp) 2748 ENDIF 2749 IF( ASSOCIATED(td_lay%i_lci) )THEN 2750 DEALLOCATE(td_lay%i_lci) 2751 ENDIF 2752 IF( ASSOCIATED(td_lay%i_lcj) )THEN 2753 DEALLOCATE(td_lay%i_lcj) 2754 ENDIF 2755 2756 td_lay%i_niproc=0 2757 td_lay%i_njproc=0 2758 td_lay%i_nland =0 2759 td_lay%i_nsea =0 2760 2761 td_lay%i_mean =0 2762 td_lay%i_min =0 2763 td_lay%i_max =0 2764 2765 END SUBROUTINE layout__clean 2766 !------------------------------------------------------------------- 2767 !> @brief 2768 !> This subroutine copy domain layout structure in another one. 2769 !> 2770 !> @warning do not use on the output of a function who create or read a 2771 !> structure (ex: tl_seg=seg__copy(seg__init()) is forbidden). 2772 !> This will create memory leaks. 2773 !> @warning to avoid infinite loop, do not use any function inside 2774 !> this subroutine 2775 !> 2776 !> @author J.Paul 2777 !> @date October, 2015 - Initial Version 2778 ! 2779 !> @param[in] td_lay domain layout structure 2780 !> @return copy of input domain layout structure 2781 !------------------------------------------------------------------- 2782 FUNCTION layout__copy( td_lay ) 2783 IMPLICIT NONE 2784 ! Argument 2785 TYPE(TLAY), INTENT(IN) :: td_lay 2786 ! function 2787 TYPE(TLAY) :: layout__copy 2788 2789 ! local variable 2790 INTEGER(i4), DIMENSION(2) :: il_shape 2791 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp 2792 ! loop indices 2793 !---------------------------------------------------------------- 2794 2795 ! copy scalar 2796 layout__copy%i_niproc = td_lay%i_niproc 2797 layout__copy%i_njproc = td_lay%i_njproc 2798 layout__copy%i_nland = td_lay%i_nland 2799 layout__copy%i_nsea = td_lay%i_nsea 2800 layout__copy%i_mean = td_lay%i_mean 2801 layout__copy%i_min = td_lay%i_min 2802 layout__copy%i_max = td_lay%i_max 2803 2804 ! copy pointers 2805 IF( ASSOCIATED(layout__copy%i_msk) )THEN 2806 DEALLOCATE(layout__copy%i_msk) 2807 ENDIF 2808 IF( ASSOCIATED(td_lay%i_msk) )THEN 2809 il_shape(:)=SHAPE(td_lay%i_msk(:,:)) 2810 ALLOCATE( layout__copy%i_msk(il_shape(jp_I),il_shape(jp_J)) ) 2811 layout__copy%i_msk(:,:)=td_lay%i_msk(:,:) 2812 ENDIF 2813 2814 IF( ASSOCIATED(layout__copy%i_msk) ) DEALLOCATE(layout__copy%i_msk) 2815 IF( ASSOCIATED(td_lay%i_msk) )THEN 2816 il_shape(:)=SHAPE(td_lay%i_msk(:,:)) 2817 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2818 il_tmp(:,:)=td_lay%i_msk(:,:) 2819 2820 ALLOCATE( layout__copy%i_msk(il_shape(jp_I),il_shape(jp_J)) ) 2821 layout__copy%i_msk(:,:)=il_tmp(:,:) 2822 2823 DEALLOCATE(il_tmp) 2824 ENDIF 2825 2826 IF( ASSOCIATED(layout__copy%i_impp) ) DEALLOCATE(layout__copy%i_impp) 2827 IF( ASSOCIATED(td_lay%i_impp) )THEN 2828 il_shape(:)=SHAPE(td_lay%i_impp(:,:)) 2829 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2830 il_tmp(:,:)=td_lay%i_impp(:,:) 2831 2832 ALLOCATE( layout__copy%i_impp(il_shape(jp_I),il_shape(jp_J)) ) 2833 layout__copy%i_impp(:,:)=il_tmp(:,:) 2834 2835 DEALLOCATE(il_tmp) 2836 ENDIF 2837 2838 IF( ASSOCIATED(layout__copy%i_jmpp) ) DEALLOCATE(layout__copy%i_jmpp) 2839 IF( ASSOCIATED(td_lay%i_jmpp) )THEN 2840 il_shape(:)=SHAPE(td_lay%i_jmpp(:,:)) 2841 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2842 il_tmp(:,:)=td_lay%i_jmpp(:,:) 2843 2844 ALLOCATE( layout__copy%i_jmpp(il_shape(jp_I),il_shape(jp_J)) ) 2845 layout__copy%i_jmpp(:,:)=il_tmp(:,:) 2846 2847 DEALLOCATE(il_tmp) 2848 ENDIF 2849 2850 IF( ASSOCIATED(layout__copy%i_lci) ) DEALLOCATE(layout__copy%i_lci) 2851 IF( ASSOCIATED(td_lay%i_lci) )THEN 2852 il_shape(:)=SHAPE(td_lay%i_lci(:,:)) 2853 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2854 il_tmp(:,:)=td_lay%i_lci(:,:) 2855 2856 ALLOCATE( layout__copy%i_lci(il_shape(jp_I),il_shape(jp_J)) ) 2857 layout__copy%i_lci(:,:)=il_tmp(:,:) 2858 2859 DEALLOCATE(il_tmp) 2860 ENDIF 2861 2862 IF( ASSOCIATED(layout__copy%i_lcj) ) DEALLOCATE(layout__copy%i_lcj) 2863 IF( ASSOCIATED(td_lay%i_lcj) )THEN 2864 il_shape(:)=SHAPE(td_lay%i_lcj(:,:)) 2865 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2866 il_tmp(:,:)=td_lay%i_lcj(:,:) 2867 2868 ALLOCATE( layout__copy%i_lcj(il_shape(jp_I),il_shape(jp_J)) ) 2869 layout__copy%i_lcj(:,:)=il_tmp(:,:) 2870 2871 DEALLOCATE(il_tmp) 2872 ENDIF 2873 2874 END FUNCTION layout__copy 2875 !------------------------------------------------------------------- 2876 !> @brief 2877 !> This subroutine create mpp structure using domain layout 2878 !> 2879 !> @detail 2880 ! 2881 !> @author J.Paul 2882 !> @date October, 2015 - Initial version 2588 2883 ! 2589 2884 !> @param[inout] td_mpp mpp strcuture 2590 !------------------------------------------------------------------- 2591 SUBROUTINE mpp__compute( td_mpp ) 2885 !> @param[in] td_lay domain layout structure 2886 !------------------------------------------------------------------- 2887 SUBROUTINE mpp__create_layout( td_mpp, td_lay ) 2592 2888 IMPLICIT NONE 2593 2889 ! Argument 2594 2890 TYPE(TMPP), INTENT(INOUT) :: td_mpp 2891 TYPE(TLAY), INTENT(IN ) :: td_lay 2595 2892 2596 2893 ! local variable 2597 INTEGER(i4) :: il_isize !< i-direction maximum sub domain size2598 INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size2599 INTEGER(i4) :: il_resti !<2600 INTEGER(i4) :: il_restj !<2601 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_nlci2602 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_nlcj2603 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_impp2604 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_jmpp2605 2606 2894 CHARACTER(LEN=lc) :: cl_file 2607 2895 TYPE(TFILE) :: tl_proc … … 2617 2905 td_mpp%i_nproc=0 2618 2906 2619 CALL logger_trace( "MPP COMPUTE: compute domain decomposition with "//& 2620 & TRIM(fct_str(td_mpp%i_niproc))//" x "//& 2621 & TRIM(fct_str(td_mpp%i_njproc))//" processors") 2622 ! maximum size of sub domain 2623 il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (td_mpp%i_niproc-1))/ & 2624 & td_mpp%i_niproc) + 2*td_mpp%i_preci 2625 il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (td_mpp%i_njproc-1))/ & 2626 & td_mpp%i_njproc) + 2*td_mpp%i_precj 2627 2628 il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, td_mpp%i_niproc) 2629 il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, td_mpp%i_njproc) 2630 IF( il_resti == 0 ) il_resti = td_mpp%i_niproc 2631 IF( il_restj == 0 ) il_restj = td_mpp%i_njproc 2632 2633 ! compute dimension of each sub domain 2634 ALLOCATE( il_nlci(td_mpp%i_niproc,td_mpp%i_njproc) ) 2635 ALLOCATE( il_nlcj(td_mpp%i_niproc,td_mpp%i_njproc) ) 2636 2637 il_nlci( 1 : il_resti , : ) = il_isize 2638 il_nlci( il_resti+1 : td_mpp%i_niproc, : ) = il_isize-1 2639 2640 il_nlcj( : , 1 : il_restj ) = il_jsize 2641 il_nlcj( : , il_restj+1 : td_mpp%i_njproc) = il_jsize-1 2642 2643 ! compute first index of each sub domain 2644 ALLOCATE( il_impp(td_mpp%i_niproc,td_mpp%i_njproc) ) 2645 ALLOCATE( il_jmpp(td_mpp%i_niproc,td_mpp%i_njproc) ) 2646 2647 il_impp(:,:)=1 2648 il_jmpp(:,:)=1 2649 2650 DO jj=1,td_mpp%i_njproc 2651 DO ji=2,td_mpp%i_niproc 2652 il_impp(ji,jj)=il_impp(ji-1,jj)+il_nlci(ji-1,jj)-2*td_mpp%i_preci 2907 CALL logger_debug( "MPP CREATE LAYOUT: create domain decomposition with "//& 2908 & TRIM(fct_str(td_lay%i_niproc))//" x "//& 2909 & TRIM(fct_str(td_lay%i_njproc))//" = "//& 2910 & TRIM(fct_str(td_lay%i_nsea))//" processors") 2911 2912 IF( lm_layout )THEN 2913 WRITE(im_iumout,*) ' choix optimum' 2914 WRITE(im_iumout,*) ' =============' 2915 WRITE(im_iumout,*) 2916 ! print info 2917 WRITE(im_iumout,*) ' ' 2918 WRITE(im_iumout,*) " jpni=",td_lay%i_niproc ," jpnj=",td_lay%i_njproc 2919 WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj 2920 2921 2922 WRITE(im_iumout,*) ' nombre de processeurs ',td_lay%i_niproc*td_lay%i_njproc 2923 WRITE(im_iumout,*) ' nombre de processeurs mer ',td_lay%i_nsea 2924 WRITE(im_iumout,*) ' nombre de processeurs terre ',td_lay%i_nland 2925 WRITE(im_iumout,*) ' moyenne de recouvrement ',td_lay%i_mean 2926 WRITE(im_iumout,*) ' minimum de recouvrement ',td_lay%i_min 2927 WRITE(im_iumout,*) ' maximum de recouvrement ',td_lay%i_max 2928 ENDIF 2929 2930 td_mpp%i_niproc=td_lay%i_niproc 2931 td_mpp%i_njproc=td_lay%i_njproc 2932 !td_mpp%i_nproc =td_lay%i_nsea 2933 2934 IF( td_mpp%i_niproc*td_mpp%i_njproc == td_lay%i_nsea )THEN 2935 IF( td_lay%i_nsea == 1 )THEN 2936 td_mpp%c_dom='full' 2937 ELSE 2938 td_mpp%c_dom='nooverlap' 2939 ENDIF 2940 ELSE 2941 td_mpp%c_dom='noextra' 2942 ENDIF 2943 2944 jk=0 2945 DO jj=1,td_lay%i_njproc 2946 DO ji=1,td_lay%i_niproc 2947 2948 IF( td_lay%i_msk(ji,jj) >= 1 )THEN 2949 2950 ! get processor file name 2951 cl_file=file_rename(td_mpp%c_name,jk) 2952 ! initialise file structure 2953 tl_proc=file_init(cl_file,td_mpp%c_type) 2954 2955 ! procesor id 2956 tl_proc%i_pid=jk 2957 2958 tl_att=att_init("DOMAIN_number",tl_proc%i_pid) 2959 CALL file_add_att(tl_proc, tl_att) 2960 2961 ! processor indices 2962 tl_proc%i_iind=ji 2963 tl_proc%i_jind=jj 2964 2965 ! fill processor dimension and first indices 2966 tl_proc%i_impp = td_lay%i_impp(ji,jj) 2967 tl_proc%i_jmpp = td_lay%i_jmpp(ji,jj) 2968 2969 tl_proc%i_lci = td_lay%i_lci(ji,jj) 2970 tl_proc%i_lcj = td_lay%i_lcj(ji,jj) 2971 2972 ! compute first and last indoor indices 2973 2974 ! west boundary 2975 IF( ji == 1 )THEN 2976 tl_proc%i_ldi = 1 2977 tl_proc%l_ctr = .TRUE. 2978 ELSE 2979 tl_proc%i_ldi = 1 + td_mpp%i_preci 2980 ENDIF 2981 2982 ! south boundary 2983 IF( jj == 1 )THEN 2984 tl_proc%i_ldj = 1 2985 tl_proc%l_ctr = .TRUE. 2986 ELSE 2987 tl_proc%i_ldj = 1 + td_mpp%i_precj 2988 ENDIF 2989 2990 ! east boundary 2991 IF( ji == td_mpp%i_niproc )THEN 2992 tl_proc%i_lei = td_lay%i_lci(ji,jj) 2993 tl_proc%l_ctr = .TRUE. 2994 ELSE 2995 tl_proc%i_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci 2996 ENDIF 2997 2998 ! north boundary 2999 IF( jj == td_mpp%i_njproc )THEN 3000 tl_proc%i_lej = td_lay%i_lcj(ji,jj) 3001 tl_proc%l_ctr = .TRUE. 3002 ELSE 3003 tl_proc%i_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj 3004 ENDIF 3005 3006 ! add processor to mpp structure 3007 CALL mpp__add_proc(td_mpp, tl_proc) 3008 3009 ! clean 3010 CALL att_clean(tl_att) 3011 CALL file_clean(tl_proc) 3012 3013 ! update proc number 3014 jk=jk+1 !ji+(jj-1)*td_lay%i_niproc 3015 3016 ENDIF 2653 3017 ENDDO 2654 3018 ENDDO 2655 3019 2656 DO jj=2,td_mpp%i_njproc 2657 DO ji=1,td_mpp%i_niproc 2658 il_jmpp(ji,jj)=il_jmpp(ji,jj-1)+il_nlcj(ji,jj-1)-2*td_mpp%i_precj 2659 ENDDO 2660 ENDDO 2661 2662 DO jj=1,td_mpp%i_njproc 2663 DO ji=1,td_mpp%i_niproc 2664 2665 jk=ji+(jj-1)*td_mpp%i_niproc 2666 2667 ! get processor file name 2668 cl_file=file_rename(td_mpp%c_name,jk) 2669 ! initialise file structure 2670 tl_proc=file_init(cl_file,td_mpp%c_type) 2671 2672 ! procesor id 2673 tl_proc%i_pid=jk 2674 2675 tl_att=att_init("DOMAIN_number",tl_proc%i_pid) 2676 CALL file_add_att(tl_proc, tl_att) 2677 2678 ! processor indices 2679 tl_proc%i_iind=ji 2680 tl_proc%i_jind=jj 2681 2682 ! fill processor dimension and first indices 2683 tl_proc%i_impp = il_impp(ji,jj) 2684 tl_proc%i_jmpp = il_jmpp(ji,jj) 2685 2686 tl_att=att_init( "DOMAIN_poistion_first", & 2687 & (/tl_proc%i_impp, tl_proc%i_jmpp/) ) 2688 CALL file_add_att(tl_proc, tl_att) 2689 2690 tl_proc%i_lci = il_nlci(ji,jj) 2691 tl_proc%i_lcj = il_nlcj(ji,jj) 2692 2693 tl_att=att_init( "DOMAIN_poistion_last", & 2694 & (/tl_proc%i_lci, tl_proc%i_lcj/) ) 2695 CALL file_add_att(tl_proc, tl_att) 2696 2697 ! compute first and last indoor indices 2698 2699 ! west boundary 2700 IF( ji == 1 )THEN 2701 tl_proc%i_ldi = 1 2702 tl_proc%l_ctr = .TRUE. 2703 ELSE 2704 tl_proc%i_ldi = 1 + td_mpp%i_preci 2705 ENDIF 2706 2707 ! south boundary 2708 IF( jj == 1 )THEN 2709 tl_proc%i_ldj = 1 2710 tl_proc%l_ctr = .TRUE. 2711 ELSE 2712 tl_proc%i_ldj = 1 + td_mpp%i_precj 2713 ENDIF 2714 2715 ! east boundary 2716 IF( ji == td_mpp%i_niproc )THEN 2717 tl_proc%i_lei = il_nlci(ji,jj) 2718 tl_proc%l_ctr = .TRUE. 2719 ELSE 2720 tl_proc%i_lei = il_nlci(ji,jj) - td_mpp%i_preci 2721 ENDIF 2722 2723 ! north boundary 2724 IF( jj == td_mpp%i_njproc )THEN 2725 tl_proc%i_lej = il_nlcj(ji,jj) 2726 tl_proc%l_ctr = .TRUE. 2727 ELSE 2728 tl_proc%i_lej = il_nlcj(ji,jj) - td_mpp%i_precj 2729 ENDIF 2730 2731 tl_att=att_init( "DOMAIN_halo_size_start", & 2732 & (/tl_proc%i_ldi, tl_proc%i_ldj/) ) 2733 CALL file_add_att(tl_proc, tl_att) 2734 tl_att=att_init( "DOMAIN_halo_size_end", & 2735 & (/tl_proc%i_ldi, tl_proc%i_ldj/) ) 2736 CALL file_add_att(tl_proc, tl_att) 2737 2738 ! add processor to mpp structure 2739 CALL mpp__add_proc(td_mpp, tl_proc) 2740 2741 ! clean 2742 CALL att_clean(tl_att) 2743 CALL file_clean(tl_proc) 2744 2745 ENDDO 2746 ENDDO 2747 2748 DEALLOCATE( il_impp, il_jmpp ) 2749 DEALLOCATE( il_nlci, il_nlcj ) 2750 2751 END SUBROUTINE mpp__compute 3020 END SUBROUTINE mpp__create_layout 2752 3021 !------------------------------------------------------------------- 2753 3022 !> @brief 2754 !> This subroutine remove land processor from domain decomposition. 2755 !> 3023 !> This subroutine optimize the number of sub domain to be used, given mask. 3024 !> @details 3025 !> Actually it get the domain decomposition with the most land 3026 !> processors removed. 3027 !> If no land processor could be removed, it get the decomposition with the 3028 !> most sea processors. 3029 ! 2756 3030 !> @author J.Paul 2757 3031 !> @date November, 2013 - Initial version 2758 !> 3032 !> @date October, 2015 3033 !> - improve way to compute domain layout 3034 !> @date February, 2016 3035 !> - new criteria for domain layout in case no land proc 3036 ! 2759 3037 !> @param[inout] td_mpp mpp strcuture 2760 !> @param[in] id_mask sub domain mask (sea=1, land=0) 2761 !------------------------------------------------------------------- 2762 SUBROUTINE mpp__del_land( td_mpp, id_mask ) 3038 !> @param[in] id_mask sub domain mask (sea=1, land=0) 3039 !> @pram[in] id_nproc maximum number of processor to be used 3040 !------------------------------------------------------------------- 3041 SUBROUTINE mpp__optimiz( td_mpp, id_mask, id_nproc ) 2763 3042 IMPLICIT NONE 2764 3043 ! Argument 2765 3044 TYPE(TMPP), INTENT(INOUT) :: td_mpp 2766 3045 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 2767 2768 ! loop indices 2769 INTEGER(i4) :: jk 2770 !---------------------------------------------------------------- 2771 2772 IF( ASSOCIATED(td_mpp%t_proc) )THEN 2773 jk=1 2774 DO WHILE( jk <= td_mpp%i_nproc ) 2775 IF( mpp__land_proc(td_mpp, jk, id_mask(:,:)) )THEN 2776 CALL mpp__del_proc(td_mpp, jk) 2777 ELSE 2778 jk=jk+1 2779 ENDIF 2780 ENDDO 2781 ELSE 2782 CALL logger_error("MPP DEL LAND: domain decomposition not define.") 2783 ENDIF 2784 2785 END SUBROUTINE mpp__del_land 2786 !------------------------------------------------------------------- 2787 !> @brief 2788 !> This subroutine optimize the number of sub domain to be used, given mask. 2789 !> @details 2790 !> Actually it get the domain decomposition with the most land 2791 !> processor removed. 2792 ! 2793 !> @author J.Paul 2794 !> @date November, 2013 - Initial version 2795 ! 2796 !> @param[inout] td_mpp mpp strcuture 2797 !> @param[in] id_mask sub domain mask (sea=1, land=0) 2798 !------------------------------------------------------------------- 2799 SUBROUTINE mpp__optimiz( td_mpp, id_mask ) 2800 IMPLICIT NONE 2801 ! Argument 2802 TYPE(TMPP), INTENT(INOUT) :: td_mpp 2803 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 3046 INTEGER(i4) , INTENT(IN) :: id_nproc 2804 3047 2805 3048 ! local variable 2806 TYPE(TMPP) :: tl_mpp 2807 INTEGER(i4) :: il_maxproc 2808 2809 TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc 3049 TYPE(TLAY) :: tl_lay 3050 TYPE(TLAY) :: tl_sav 3051 3052 REAL(dp) :: dl_min 3053 REAL(dp) :: dl_max 3054 REAL(dp) :: dl_ratio 3055 REAL(dp) :: dl_sav 3056 2810 3057 ! loop indices 2811 3058 INTEGER(i4) :: ji … … 2814 3061 2815 3062 CALL logger_trace("MPP OPTIMIZ: look for best domain decomposition") 2816 tl_mpp=mpp_copy(td_mpp) 2817 2818 ! save maximum number of processor to be used 2819 il_maxproc=td_mpp%i_nproc 3063 dl_sav=0 2820 3064 ! 2821 td_mpp%i_nproc=0 2822 DO ji=1,il_maxproc 2823 DO jj=1,il_maxproc 2824 2825 ! clean mpp processor 2826 IF( ASSOCIATED(tl_mpp%t_proc) )THEN 2827 CALL file_clean(tl_mpp%t_proc(:)) 2828 DEALLOCATE(tl_mpp%t_proc) 2829 ENDIF 2830 2831 ! compute domain decomposition 2832 tl_mpp%i_niproc=ji 2833 tl_mpp%i_njproc=jj 2834 2835 CALL mpp__compute( tl_mpp ) 2836 2837 ! remove land sub domain 2838 CALL mpp__del_land( tl_mpp, id_mask ) 2839 2840 CALL logger_info("MPP OPTIMIZ: number of processor "//& 2841 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 2842 & TRIM(fct_str(tl_mpp%i_nproc)) ) 2843 IF( tl_mpp%i_nproc > td_mpp%i_nproc .AND. & 2844 & tl_mpp%i_nproc <= il_maxproc )THEN 2845 ! save optimiz decomposition 2846 2847 CALL logger_info("MPP OPTIMIZ:save this decomposition "//& 2848 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 2849 & TRIM(fct_str(tl_mpp%i_nproc)) ) 2850 2851 ! clean mpp 2852 CALL mpp_clean(td_mpp) 2853 2854 ! save processor array 2855 ALLOCATE( tl_proc(tl_mpp%i_nproc) ) 2856 tl_proc(:)=file_copy(tl_mpp%t_proc(:)) 2857 2858 ! remove pointer on processor array 2859 CALL file_clean(tl_mpp%t_proc(:)) 2860 DEALLOCATE(tl_mpp%t_proc) 2861 2862 ! save data except processor array 2863 td_mpp=mpp_copy(tl_mpp) 2864 2865 ! save processor array 2866 ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc) ) 2867 td_mpp%t_proc(:)=file_copy(tl_proc(:)) 2868 2869 ! clean 2870 CALL file_clean( tl_proc(:) ) 2871 DEALLOCATE(tl_proc) 2872 2873 ENDIF 2874 3065 DO ji=1,id_nproc 3066 DO jj=1,id_nproc 3067 3068 ! compute domain layout 3069 tl_lay=layout__init( td_mpp, id_mask, ji,jj ) 3070 IF( tl_lay%i_nsea <= id_nproc )THEN 3071 3072 IF( ASSOCIATED(tl_sav%i_lci) )THEN 3073 IF( tl_sav%i_nland /= 0 )THEN 3074 ! look for layout with most land proc 3075 IF( tl_lay%i_nland > tl_sav%i_nland .OR. & 3076 & ( tl_lay%i_nland == tl_sav%i_nland .AND. & 3077 & tl_lay%i_min > tl_sav%i_min ) )THEN 3078 ! save optimiz layout 3079 CALL logger_info("MPP OPTIMIZ:save this decomposition "//& 3080 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 3081 & TRIM(fct_str(tl_lay%i_nsea)) ) 3082 3083 tl_sav=layout__copy(tl_lay) 3084 ENDIF 3085 ELSE ! tl_sav%i_nland == 0 3086 ! look for layout with most sea proc 3087 ! and "square" cell 3088 dl_min=MIN(tl_lay%i_lci(1,1),tl_lay%i_lcj(1,1)) 3089 dl_max=MAX(tl_lay%i_lci(1,1),tl_lay%i_lcj(1,1)) 3090 dl_ratio=dl_min/dl_max 3091 IF( tl_lay%i_nsea > tl_sav%i_nsea .OR. & 3092 & ( tl_lay%i_nsea == tl_sav%i_nsea .AND. & 3093 & dl_ratio > dl_sav ) )THEN 3094 ! save optimiz layout 3095 CALL logger_info("MPP OPTIMIZ:save this decomposition "//& 3096 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 3097 & TRIM(fct_str(tl_lay%i_nsea)) ) 3098 3099 tl_sav=layout__copy(tl_lay) 3100 dl_sav=dl_ratio 3101 ENDIF 3102 ENDIF 3103 ELSE 3104 ! init tl_sav 3105 tl_sav=layout__copy(tl_lay) 3106 3107 dl_min=MIN(tl_sav%i_lci(1,1),tl_sav%i_lcj(1,1)) 3108 dl_max=MAX(tl_sav%i_lci(1,1),tl_sav%i_lcj(1,1)) 3109 dl_sav=dl_min/dl_max 3110 ENDIF 3111 3112 ENDIF 3113 3114 ! clean 3115 CALL layout__clean( tl_lay ) 3116 2875 3117 ENDDO 2876 3118 ENDDO 2877 3119 3120 ! create mpp domain layout 3121 CALL mpp__create_layout(td_mpp, tl_sav) 3122 2878 3123 ! clean 2879 CALL mpp_clean(tl_mpp)3124 CALL layout__clean( tl_sav ) 2880 3125 2881 3126 END SUBROUTINE mpp__optimiz 2882 !-------------------------------------------------------------------2883 !> @brief2884 !> This function check if processor is a land processor.2885 !>2886 !> @author J.Paul2887 !> @date November, 2013 - Initial version2888 !>2889 !> @param[in] td_mpp mpp strcuture2890 !> @param[in] id_proc processor id2891 !> @param[in] id_mask sub domain mask (sea=1, land=0)2892 !-------------------------------------------------------------------2893 LOGICAL FUNCTION mpp__land_proc( td_mpp , id_proc, id_mask )2894 IMPLICIT NONE2895 ! Argument2896 TYPE(TMPP), INTENT(IN) :: td_mpp2897 INTEGER(i4), INTENT(IN) :: id_proc2898 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask2899 2900 ! local variable2901 INTEGER(i4), DIMENSION(2) :: il_shape2902 !----------------------------------------------------------------2903 2904 CALL logger_trace("MPP LAND PROC: check processor "//TRIM(fct_str(id_proc))//&2905 & " of mpp "//TRIM(td_mpp%c_name) )2906 mpp__land_proc=.FALSE.2907 IF( ASSOCIATED(td_mpp%t_proc) )THEN2908 2909 il_shape(:)=SHAPE(id_mask)2910 IF( il_shape(1) /= td_mpp%t_dim(1)%i_len .OR. &2911 & il_shape(2) /= td_mpp%t_dim(2)%i_len )THEN2912 CALL logger_debug("MPP LAND PROC: mask size ("//&2913 & TRIM(fct_str(il_shape(1)))//","//&2914 & TRIM(fct_str(il_shape(2)))//")")2915 CALL logger_debug("MPP LAND PROC: domain size ("//&2916 & TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&2917 & TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")")2918 CALL logger_error("MPP LAND PROC: mask and domain size differ")2919 ELSE2920 IF( ALL(id_mask( td_mpp%t_proc(id_proc)%i_impp + &2921 & td_mpp%t_proc(id_proc)%i_ldi - 1 : &2922 & td_mpp%t_proc(id_proc)%i_impp + &2923 & td_mpp%t_proc(id_proc)%i_lei - 1, &2924 & td_mpp%t_proc(id_proc)%i_jmpp + &2925 & td_mpp%t_proc(id_proc)%i_ldj - 1 : &2926 & td_mpp%t_proc(id_proc)%i_jmpp + &2927 & td_mpp%t_proc(id_proc)%i_lej - 1) &2928 & /= 1 ) )THEN2929 ! land domain2930 CALL logger_info("MPP LAND PROC: processor "//TRIM(fct_str(id_proc))//&2931 & " is land processor")2932 mpp__land_proc=.TRUE.2933 ENDIF2934 ENDIF2935 2936 ELSE2937 CALL logger_error("MPP LAND PROC: domain decomposition not define.")2938 ENDIF2939 2940 END FUNCTION mpp__land_proc2941 3127 !------------------------------------------------------------------- 2942 3128 !> @brief … … 3195 3381 SELECT CASE(TRIM(td_mpp%c_dom)) 3196 3382 CASE('full') 3197 il_i1 = 1 ; il_i2 = td_mpp%t_dim(1)%i_len 3198 il_j1 = 1 ; il_j2 = td_mpp%t_dim(2)%i_len 3199 CASE('overlap') 3200 il_i1 = td_mpp%t_proc(id_procid)%i_impp 3201 il_j1 = td_mpp%t_proc(id_procid)%i_jmpp 3202 3203 il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1 3204 il_j2 = il_j1 + td_mpp%t_proc(id_procid)%i_lcj - 1 3383 il_i1 = 1 3384 il_j1 = 1 3385 3386 il_i2 = td_mpp%t_dim(1)%i_len 3387 il_j2 = td_mpp%t_dim(2)%i_len 3388 CASE('noextra') 3389 il_i1 = td_mpp%t_proc(id_procid)%i_impp 3390 il_j1 = td_mpp%t_proc(id_procid)%i_jmpp 3391 3392 il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1 3393 il_j2 = il_j1 + td_mpp%t_proc(id_procid)%i_lcj - 1 3205 3394 CASE('nooverlap') 3206 3395 il_i1 = td_mpp%t_proc(id_procid)%i_impp + & … … 3214 3403 & td_mpp%t_proc(id_procid)%i_lej - 1 3215 3404 CASE DEFAULT 3216 CALL logger_error("MPP GET PROC INDEX: invalid decomposition type.") 3405 CALL logger_error("MPP GET PROC INDEX: invalid "//& 3406 & "decomposition type.") 3217 3407 END SELECT 3218 3408 … … 3264 3454 il_jsize = td_mpp%t_dim(2)%i_len 3265 3455 3266 CASE(' overlap')3456 CASE('noextra') 3267 3457 3268 3458 il_isize = td_mpp%t_proc(id_procid)%i_lci … … 3308 3498 IF( ASSOCIATED(td_mpp%t_proc) )THEN 3309 3499 3310 IF( td_mpp%i_niproc == 0 .AND. td_mpp%i_n iproc == 0 )THEN3500 IF( td_mpp%i_niproc == 0 .AND. td_mpp%i_njproc == 0 )THEN 3311 3501 CALL logger_info("MPP GET DOM: use indoor indices to get domain "//& 3312 3502 & "decomposition type.") … … 3323 3513 & td_mpp%t_proc(1)%i_lcj ) )THEN 3324 3514 3325 td_mpp%c_dom=' overlap'3515 td_mpp%c_dom='noextra' 3326 3516 3327 3517 ELSEIF((td_mpp%t_proc(1)%t_dim(1)%i_len == & … … 3368 3558 td_mpp%c_dom='nooverlap' 3369 3559 ELSE 3370 td_mpp%c_dom=' overlap'3560 td_mpp%c_dom='noextra' 3371 3561 ENDIF 3372 3562 … … 3386 3576 !> @author J.Paul 3387 3577 !> @date November, 2013 - Initial Version 3578 !> @date September 2015 3579 !> - do not check used dimension here 3388 3580 !> 3389 3581 !> @param[in] td_mpp mpp structure … … 3398 3590 3399 3591 ! local variable 3592 CHARACTER(LEN=lc) :: cl_dim 3593 LOGICAL :: ll_error 3594 LOGICAL :: ll_warn 3595 3596 INTEGER(i4) :: il_ind 3400 3597 3401 3598 ! loop indices … … 3403 3600 !---------------------------------------------------------------- 3404 3601 mpp__check_var_dim=.TRUE. 3602 3405 3603 ! check used dimension 3406 IF( ANY( td_var%t_dim(:)%l_use .AND. & 3407 & td_var%t_dim(:)%i_len /= td_mpp%t_dim(:)%i_len) )THEN 3604 ll_error=.FALSE. 3605 ll_warn=.FALSE. 3606 DO ji=1,ip_maxdim 3607 il_ind=dim_get_index( td_mpp%t_dim(:), & 3608 & TRIM(td_var%t_dim(ji)%c_name), & 3609 & TRIM(td_var%t_dim(ji)%c_sname)) 3610 IF( il_ind /= 0 )THEN 3611 IF( td_var%t_dim(ji)%l_use .AND. & 3612 & td_mpp%t_dim(il_ind)%l_use .AND. & 3613 & td_var%t_dim(ji)%i_len /= td_mpp%t_dim(il_ind)%i_len )THEN 3614 IF( INDEX( TRIM(td_var%c_axis), & 3615 & TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN 3616 ll_warn=.TRUE. 3617 ELSE 3618 ll_error=.TRUE. 3619 ENDIF 3620 ENDIF 3621 ENDIF 3622 ENDDO 3623 3624 IF( ll_error )THEN 3625 3626 cl_dim='(/' 3627 DO ji = 1, td_mpp%i_ndim 3628 IF( td_mpp%t_dim(ji)%l_use )THEN 3629 cl_dim=TRIM(cl_dim)//& 3630 & TRIM(fct_upper(td_mpp%t_dim(ji)%c_sname))//':'//& 3631 & TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//',' 3632 ENDIF 3633 ENDDO 3634 cl_dim=TRIM(cl_dim)//'/)' 3635 CALL logger_debug( " mpp dimension: "//TRIM(cl_dim) ) 3636 3637 cl_dim='(/' 3638 DO ji = 1, td_var%i_ndim 3639 IF( td_var%t_dim(ji)%l_use )THEN 3640 cl_dim=TRIM(cl_dim)//& 3641 & TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//& 3642 & TRIM(fct_str(td_var%t_dim(ji)%i_len))//',' 3643 ENDIF 3644 ENDDO 3645 cl_dim=TRIM(cl_dim)//'/)' 3646 CALL logger_debug( " variable dimension: "//TRIM(cl_dim) ) 3408 3647 3409 3648 mpp__check_var_dim=.FALSE. 3410 3649 3411 CALL logger_debug( &3412 & " mpp dimension: "//TRIM(fct_str(td_mpp%i_ndim))//&3413 & " variable dimension: "//TRIM(fct_str(td_var%i_ndim)) )3414 DO ji = 1, ip_maxdim3415 CALL logger_debug( &3416 & "MPP CHECK DIM: for dimension "//&3417 & TRIM(td_mpp%t_dim(ji)%c_name)//&3418 & ", mpp length: "//&3419 & TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//&3420 & ", variable length: "//&3421 & TRIM(fct_str(td_var%t_dim(ji)%i_len))//&3422 & ", variable used "//TRIM(fct_str(td_var%t_dim(ji)%l_use)))3423 ENDDO3424 3425 3650 CALL logger_error( & 3426 & " MPP CHECK DIM: variable and mppdimension differ"//&3651 & " MPP CHECK VAR DIM: variable and file dimension differ"//& 3427 3652 & " for variable "//TRIM(td_var%c_name)//& 3428 & " and mpp "//TRIM(td_mpp%c_name)) 3653 & " and file "//TRIM(td_mpp%c_name)) 3654 3655 ELSEIF( ll_warn )THEN 3656 CALL logger_warn( & 3657 & " MPP CHECK VAR DIM: variable and file dimension differ"//& 3658 & " for variable "//TRIM(td_var%c_name)//& 3659 & " and file "//TRIM(td_mpp%c_name)//". you should use"//& 3660 & " var_check_dim to remove useless dimension.") 3661 ELSE 3662 3663 IF( td_var%i_ndim > td_mpp%i_ndim )THEN 3664 CALL logger_info("MPP CHECK VAR DIM: variable "//& 3665 & TRIM(td_var%c_name)//" use more dimension than file "//& 3666 & TRIM(td_mpp%c_name)//" do until now.") 3667 ENDIF 3429 3668 3430 3669 ENDIF … … 3583 3822 ENDIF 3584 3823 END FUNCTION mpp_recombine_var 3824 !------------------------------------------------------------------- 3825 !> @brief This subroutine read subdomain indices defined with halo 3826 !> (NEMO netcdf way) 3827 !> 3828 !> @author J.Paul 3829 !> @date January, 2016 - Initial Version 3830 !> 3831 !> @param[inout] td_file mpp structure 3832 !------------------------------------------------------------------- 3833 SUBROUTINE mpp__read_halo(td_file, td_dimglo) 3834 IMPLICIT NONE 3835 ! Argument 3836 TYPE(TFILE) , INTENT(INOUT) :: td_file 3837 TYPE(TDIM) , DIMENSION(:), INTENT(IN ) :: td_dimglo 3838 3839 ! local variable 3840 INTEGER(i4) :: il_attid 3841 INTEGER(i4) :: il_ifirst 3842 INTEGER(i4) :: il_jfirst 3843 INTEGER(i4) :: il_ilast 3844 INTEGER(i4) :: il_jlast 3845 INTEGER(i4) :: il_ihalostart 3846 INTEGER(i4) :: il_jhalostart 3847 INTEGER(i4) :: il_ihaloend 3848 INTEGER(i4) :: il_jhaloend 3849 3850 CHARACTER(LEN=lc) :: cl_dom 3851 !---------------------------------------------------------------- 3852 3853 ! DOMAIN_position_first 3854 il_attid = 0 3855 IF( ASSOCIATED(td_file%t_att) )THEN 3856 il_attid=att_get_id( td_file%t_att, "DOMAIN_position_first" ) 3857 ENDIF 3858 IF( il_attid /= 0 )THEN 3859 il_ifirst = INT(td_file%t_att(il_attid)%d_value(1)) 3860 il_jfirst = INT(td_file%t_att(il_attid)%d_value(2)) 3861 ELSE 3862 il_ifirst = 1 3863 il_jfirst = 1 3864 ENDIF 3865 3866 ! DOMAIN_position_last 3867 il_attid = 0 3868 IF( ASSOCIATED(td_file%t_att) )THEN 3869 il_attid=att_get_id( td_file%t_att, "DOMAIN_position_last" ) 3870 ENDIF 3871 IF( il_attid /= 0 )THEN 3872 il_ilast = INT(td_file%t_att(il_attid)%d_value(1)) 3873 il_jlast = INT(td_file%t_att(il_attid)%d_value(2)) 3874 ELSE 3875 il_ilast = td_file%t_dim(1)%i_len 3876 il_jlast = td_file%t_dim(2)%i_len 3877 ENDIF 3878 3879 ! DOMAIN_halo_size_start 3880 il_attid = 0 3881 IF( ASSOCIATED(td_file%t_att) )THEN 3882 il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_start" ) 3883 ENDIF 3884 IF( il_attid /= 0 )THEN 3885 il_ihalostart = INT(td_file%t_att(il_attid)%d_value(1)) 3886 il_jhalostart = INT(td_file%t_att(il_attid)%d_value(2)) 3887 ELSE 3888 il_ihalostart = 0 3889 il_jhalostart = 0 3890 ENDIF 3891 3892 ! DOMAIN_halo_size_end 3893 il_attid = 0 3894 IF( ASSOCIATED(td_file%t_att) )THEN 3895 il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_end" ) 3896 ENDIF 3897 IF( il_attid /= 0 )THEN 3898 il_ihaloend = INT(td_file%t_att(il_attid)%d_value(1)) 3899 il_jhaloend = INT(td_file%t_att(il_attid)%d_value(2)) 3900 ELSE 3901 il_ihaloend = 0 3902 il_jhaloend = 0 3903 ENDIF 3904 3905 IF( (td_dimglo(jp_I)%i_len == td_file%t_dim(jp_I)%i_len) .AND. & 3906 & (td_dimglo(jp_J)%i_len == td_file%t_dim(jp_J)%i_len) )THEN 3907 cl_dom='full' 3908 ELSEIF( il_ihalostart == 0 .AND. il_jhalostart == 0 .AND. & 3909 & il_ihaloend == 0 .AND. il_jhaloend == 0 )THEN 3910 cl_dom='nooverlap' 3911 ELSE 3912 cl_dom='noextra' 3913 ENDIF 3914 3915 SELECT CASE(TRIM(cl_dom)) 3916 CASE('full') 3917 td_file%i_impp = il_ifirst 3918 td_file%i_jmpp = il_jfirst 3919 td_file%i_lci = td_file%t_dim(jp_I)%i_len 3920 td_file%i_lcj = td_file%t_dim(jp_J)%i_len 3921 td_file%i_ldi = il_ihalostart + 1 3922 td_file%i_ldj = il_jhalostart + 1 3923 td_file%i_lei = td_file%t_dim(jp_I)%i_len - il_ihaloend 3924 td_file%i_lej = td_file%t_dim(jp_J)%i_len - il_jhaloend 3925 CASE('noextra') 3926 td_file%i_impp = il_ifirst 3927 td_file%i_jmpp = il_jfirst 3928 td_file%i_lci = td_file%t_dim(jp_I)%i_len 3929 td_file%i_lcj = td_file%t_dim(jp_J)%i_len 3930 td_file%i_ldi = il_ihalostart + 1 3931 td_file%i_ldj = il_jhalostart + 1 3932 td_file%i_lei = td_file%i_lci - il_ihaloend 3933 td_file%i_lej = td_file%i_lcj - il_jhaloend 3934 CASE('nooverlap') !!!????? 3935 td_file%i_impp = il_ifirst 3936 td_file%i_jmpp = il_jfirst 3937 td_file%i_lci = td_file%t_dim(jp_I)%i_len 3938 td_file%i_lcj = td_file%t_dim(jp_J)%i_len 3939 td_file%i_ldi = 1 3940 td_file%i_ldj = 1 3941 td_file%i_lei = td_file%t_dim(jp_I)%i_len 3942 td_file%i_lej = td_file%t_dim(jp_J)%i_len 3943 END SELECT 3944 3945 END SUBROUTINE mpp__read_halo 3946 !------------------------------------------------------------------- 3947 !> @brief This subroutine compute subdomain indices defined with halo 3948 !> (NEMO netcdf way) 3949 !> 3950 !> @author J.Paul 3951 !> @date January, 2016 - Initial Version 3952 !> 3953 !> @param[inout] td_mpp mpp structure 3954 !------------------------------------------------------------------- 3955 SUBROUTINE mpp__compute_halo(td_mpp) 3956 IMPLICIT NONE 3957 ! Argument 3958 TYPE(TMPP) , INTENT(INOUT) :: td_mpp 3959 3960 ! local variable 3961 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ifirst 3962 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jfirst 3963 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ilast 3964 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jlast 3965 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ihalostart 3966 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jhalostart 3967 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ihaloend 3968 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jhaloend 3969 3970 TYPE(TATT) :: tl_att 3971 3972 ! loop indices 3973 INTEGER(i4) :: ji 3974 !---------------------------------------------------------------- 3975 3976 ALLOCATE( il_ifirst (td_mpp%i_nproc) ) 3977 ALLOCATE( il_jfirst (td_mpp%i_nproc) ) 3978 3979 ALLOCATE( il_ilast (td_mpp%i_nproc) ) 3980 ALLOCATE( il_jlast (td_mpp%i_nproc) ) 3981 3982 ALLOCATE( il_ihalostart(td_mpp%i_nproc) ) 3983 ALLOCATE( il_jhalostart(td_mpp%i_nproc) ) 3984 3985 ALLOCATE( il_ihaloend (td_mpp%i_nproc) ) 3986 ALLOCATE( il_jhaloend (td_mpp%i_nproc) ) 3987 3988 SELECT CASE(TRIM(td_mpp%c_dom)) 3989 CASE('full') 3990 3991 il_ifirst(:)=td_mpp%t_proc(:)%i_impp 3992 il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp 3993 3994 il_ilast(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%t_dim(jp_I)%i_len - 1 3995 il_jlast(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%t_dim(jp_J)%i_len - 1 3996 3997 il_ihalostart(:)=td_mpp%t_proc(:)%i_ldi-1 3998 il_jhalostart(:)=td_mpp%t_proc(:)%i_ldj-1 3999 4000 il_ihaloend(:)=td_mpp%t_proc(:)%t_dim(jp_I)%i_len - td_mpp%t_proc(:)%i_lei 4001 il_jhaloend(:)=td_mpp%t_proc(:)%t_dim(jp_J)%i_len - td_mpp%t_proc(:)%i_lej 4002 4003 CASE('noextra') 4004 4005 il_ifirst(:)=td_mpp%t_proc(:)%i_impp 4006 il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp 4007 4008 il_ilast(:) =td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_lci - 1 4009 il_jlast(:) =td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_lcj - 1 4010 4011 il_ihalostart(:)=td_mpp%t_proc(:)%i_ldi-1 4012 il_jhalostart(:)=td_mpp%t_proc(:)%i_ldj-1 4013 4014 il_ihaloend(:)=td_mpp%t_proc(:)%i_lci - td_mpp%t_proc(:)%i_lei 4015 il_jhaloend(:)=td_mpp%t_proc(:)%i_lcj - td_mpp%t_proc(:)%i_lej 4016 4017 CASE('nooverlap') 4018 4019 il_ifirst(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_ldi - 1 4020 il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_ldj - 1 4021 4022 il_ilast(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_lei - 1 4023 il_jlast(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_lej - 1 4024 4025 il_ihalostart(:)=0 4026 il_jhalostart(:)=0 4027 4028 il_ihaloend(:)=0 4029 il_jhaloend(:)=0 4030 4031 CASE DEFAULT 4032 CALL logger_fatal("MPP INIT: invalid "//& 4033 & "decomposition type.") 4034 END SELECT 4035 4036 DO ji=1,td_mpp%i_nproc 4037 tl_att=att_init( "DOMAIN_position_first", & 4038 & (/ il_ifirst(ji), il_jfirst(ji) /) ) 4039 CALL file_move_att(td_mpp%t_proc(ji), tl_att) 4040 4041 tl_att=att_init( "DOMAIN_position_last", & 4042 & (/ il_ilast(ji), il_jlast(ji) /) ) 4043 CALL file_move_att(td_mpp%t_proc(ji), tl_att) 4044 4045 tl_att=att_init( "DOMAIN_halo_size_start", & 4046 & (/ il_ihalostart(ji), il_jhalostart(ji) /) ) 4047 CALL file_move_att( td_mpp%t_proc(ji), tl_att) 4048 4049 tl_att=att_init( "DOMAIN_halo_size_end", & 4050 & (/ il_ihaloend(ji), il_jhaloend(ji) /) ) 4051 CALL file_move_att( td_mpp%t_proc(ji), tl_att) 4052 ENDDO 4053 4054 DEALLOCATE( il_ifirst ) 4055 DEALLOCATE( il_jfirst ) 4056 4057 DEALLOCATE( il_ilast ) 4058 DEALLOCATE( il_jlast ) 4059 4060 DEALLOCATE( il_ihalostart) 4061 DEALLOCATE( il_jhalostart) 4062 4063 DEALLOCATE( il_ihaloend ) 4064 DEALLOCATE( il_jhaloend ) 4065 4066 !impp 4067 tl_att=att_init( "SUBDOMAIN_I_left_bottom_indices", td_mpp%t_proc(:)%i_impp) 4068 CALL mpp_move_att(td_mpp, tl_att) 4069 4070 tl_att=att_init( "SUBDOMAIN_J_left_bottom_indices", td_mpp%t_proc(:)%i_jmpp) 4071 CALL mpp_move_att(td_mpp, tl_att) 4072 4073 ! lci 4074 tl_att=att_init( "SUBDOMAIN_I_dimensions", td_mpp%t_proc(:)%i_lci) 4075 CALL mpp_move_att(td_mpp, tl_att) 4076 4077 tl_att=att_init( "SUBDOMAIN_J_dimensions", td_mpp%t_proc(:)%i_lcj) 4078 CALL mpp_move_att(td_mpp, tl_att) 4079 4080 ! ldi 4081 tl_att=att_init( "SUBDOMAIN_I_first_indoor_indices", td_mpp%t_proc(:)%i_ldi) 4082 CALL mpp_move_att(td_mpp, tl_att) 4083 4084 tl_att=att_init( "SUBDOMAIN_J_first_indoor_indices", td_mpp%t_proc(:)%i_ldj) 4085 CALL mpp_move_att(td_mpp, tl_att) 4086 4087 ! lei 4088 tl_att=att_init( "SUBDOMAIN_I_last_indoor_indices", td_mpp%t_proc(:)%i_lei) 4089 CALL mpp_move_att(td_mpp, tl_att) 4090 4091 tl_att=att_init( "SUBDOMAIN_J_last_indoor_indices", td_mpp%t_proc(:)%i_lej) 4092 CALL mpp_move_att(td_mpp, tl_att) 4093 4094 ! clean 4095 CALL att_clean(tl_att) 4096 4097 END SUBROUTINE mpp__compute_halo 3585 4098 END MODULE mpp 3586 4099 -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/multi.f90
r5617 r7339 173 173 !> @date July, 2015 174 174 !> - check if variable to be read is in file 175 !> @date January, 2016 176 !> - read variable dimensions 175 177 !> 176 178 !> @param[in] cd_varfile variable location information (from namelist) … … 187 189 188 190 ! local variable 189 CHARACTER(LEN=lc) :: cl_name 190 CHARACTER(LEN=lc) :: cl_lower 191 CHARACTER(LEN=lc) :: cl_file 192 CHARACTER(LEN=lc) :: cl_matrix 193 194 INTEGER(i4) :: il_nvar 195 INTEGER(i4) :: il_varid 196 197 LOGICAL :: ll_dim 198 199 TYPE(TVAR) :: tl_var 200 201 TYPE(TMPP) :: tl_mpp 191 CHARACTER(LEN=lc) :: cl_name 192 CHARACTER(LEN=lc) :: cl_lower 193 CHARACTER(LEN=lc) :: cl_file 194 CHARACTER(LEN=lc) :: cl_matrix 195 196 INTEGER(i4) :: il_nvar 197 INTEGER(i4) :: il_varid 198 199 LOGICAL :: ll_dim 200 201 TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim 202 203 TYPE(TVAR) :: tl_var 204 205 TYPE(TMPP) :: tl_mpp 202 206 203 207 ! loop indices … … 216 220 217 221 IF( LEN(TRIM(cl_file)) == lc )THEN 218 CALL logger_fatal("MULTI INIT: file name too long ( ==256)."//&219 & "check namelist.")222 CALL logger_fatal("MULTI INIT: file name too long (>"//& 223 & TRIM(fct_str(lc))//"). check namelist.") 220 224 ENDIF 221 225 … … 243 247 ! 244 248 tl_mpp=mpp_init( file_init(TRIM(cl_file)) ) 245 246 249 ! define variable 247 250 IF( TRIM(fct_lower(cl_lower)) /= 'all' )THEN … … 255 258 ENDIF 256 259 257 ! clean var 260 ! get (global) variable dimension 261 tl_dim(jp_I)=dim_copy(tl_mpp%t_dim(jp_I)) 262 tl_dim(jp_J)=dim_copy(tl_mpp%t_dim(jp_J)) 263 tl_dim(jp_K)=dim_copy(tl_mpp%t_proc(1)%t_var(il_varid)%t_dim(jp_K)) 264 tl_dim(jp_L)=dim_copy(tl_mpp%t_proc(1)%t_var(il_varid)%t_dim(jp_L)) 265 266 ! clean all varible 258 267 CALL mpp_del_var(tl_mpp) 259 268 260 tl_var=var_init(TRIM(cl_lower) )269 tl_var=var_init(TRIM(cl_lower), td_dim=tl_dim(:)) 261 270 262 271 ! add variable … … 272 281 273 282 DO jk=tl_mpp%t_proc(1)%i_nvar,1,-1 274 283 275 284 ! check if variable is dimension 276 285 ll_dim=.FALSE. … … 379 388 ! print file 380 389 IF( td_multi%i_nmpp /= 0 .AND. ASSOCIATED(td_multi%t_mpp) )THEN 381 WRITE(*,'(/a,i3)') 'MULTI: total number of mpp: ',&390 WRITE(*,'(/a,i3)') 'MULTI: total number of file(s): ',& 382 391 & td_multi%i_nmpp 383 WRITE(*,'(6x,a,i3)') ' total number of variable : ',&392 WRITE(*,'(6x,a,i3)') ' total number of variable(s): ',& 384 393 & td_multi%i_nvar 385 394 DO ji=1,td_multi%i_nmpp 386 WRITE(*,'(3x,3a)') ' MPPFILE ',TRIM(td_multi%t_mpp(ji)%c_name),&395 WRITE(*,'(3x,3a)') 'FILE ',TRIM(td_multi%t_mpp(ji)%c_name),& 387 396 & ' CONTAINS' 388 397 DO jj=1,td_multi%t_mpp(ji)%t_proc(1)%i_nvar -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/phycst.f90
r5609 r7339 12 12 ! REVISION HISTORY: 13 13 !> @date November, 2013 - Initial Version 14 !> @date September, 2015 15 !> - add physical constant to compute meshmask 14 16 ! 15 17 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 23 25 PUBLIC :: dp_pi !< pi 24 26 PUBLIC :: dp_eps !< epsilon value 25 PUBLIC :: dp_rearth !< earth radius (km)27 PUBLIC :: dp_rearth !< earth radius [m] 26 28 PUBLIC :: dp_deg2rad !< degree to radian ratio 27 29 PUBLIC :: dp_rad2deg !< radian to degree ratio 28 30 PUBLIC :: dp_delta !< 31 PUBLIC :: dp_omega !< earth rotation parameter [s-1] 32 PUBLIC :: dp_day !< day [s] 33 PUBLIC :: dp_siyea !< sideral year [s] 34 PUBLIC :: dp_siday !< sideral day [s] 35 36 REAL(wp), PUBLIC :: rday = 24.*60.*60. !: day [s] 37 REAL(wp), PUBLIC :: rsiyea !: sideral year [s] 38 REAL(wp), PUBLIC :: rsiday !: sideral day [s] 29 39 30 40 REAL(dp), PARAMETER :: dp_pi = 3.14159274101257_dp 31 41 REAL(dp), PARAMETER :: dp_eps = EPSILON(1._dp) 32 REAL(dp), PARAMETER :: dp_rearth = 6 871._dp42 REAL(dp), PARAMETER :: dp_rearth = 6371229._dp 33 43 REAL(dp), PARAMETER :: dp_deg2rad = dp_pi/180.0 34 44 REAL(dp), PARAMETER :: dp_rad2deg = 180.0/dp_pi 35 45 46 REAL(dp), PARAMETER :: dp_day = 24.*60.*60. 47 REAL(dp), PARAMETER :: dp_siyea = 365.25_wp * dp_day * & 48 & 2._wp * dp_pi / 6.283076_dp 49 REAL(dp), PARAMETER :: dp_siday = dp_day / ( 1._wp + dp_day / dp_siyea ) 50 36 51 REAL(dp), PARAMETER :: dp_delta=1.e-6 52 REAL(dp), PARAMETER :: dp_omega= 2._dp * dp_pi / dp_siday 37 53 END MODULE phycst 38 54 -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/variable.f90
r5617 r7339 285 285 !> @date July, 2015 286 286 !> - add subroutine var_chg_unit to change unit of output variable 287 !> @date Spetember, 2015 288 !> - manage useless (dummy) variable 287 289 ! 288 290 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 305 307 306 308 PUBLIC :: tg_varextra !< array of variable structure with extra information. 309 310 PRIVATE :: cm_dumvar !< dummy variable array 307 311 308 312 ! function and subroutine … … 334 338 PUBLIC :: var_chg_extra !< read variable namelist information, and modify extra information. 335 339 PUBLIC :: var_check_dim !< check variable dimension expected 340 PUBLIC :: var_get_dummy !< fill dummy variable array 341 PUBLIC :: var_is_dummy !< check if variable is defined as dummy variable 336 342 337 343 PRIVATE :: var__init ! initialize variable structure without array of value … … 445 451 !< fill when running var_def_extra() 446 452 453 CHARACTER(LEN=lc), DIMENSION(ip_maxdum), SAVE :: cm_dumvar !< dummy variable 454 447 455 INTERFACE var_init 448 456 MODULE PROCEDURE var__init ! initialize variable structure without array of value … … 6698 6706 !> given variable name or standard name. 6699 6707 !> 6700 !> @warning only variable read from file, have an id.6701 !>6702 6708 !> @author J.Paul 6703 6709 !> @date November, 2013 - Initial Version 6710 !> @date July, 2015 6711 !> - check long name 6704 6712 ! 6705 6713 !> @param[in] td_var array of variable structure … … 6735 6743 ELSE IF( fct_lower(td_var(ji)%c_stdname) == fct_lower(cd_name) .AND.& 6736 6744 & TRIM(fct_lower(td_var(ji)%c_stdname)) /= '' )THEN 6745 6746 var_get_id=td_var(ji)%i_id 6747 EXIT 6748 6749 ! look for variable long name 6750 ELSE IF( fct_lower(td_var(ji)%c_longname) == fct_lower(cd_name) .AND.& 6751 & TRIM(fct_lower(td_var(ji)%c_longname)) /= '' )THEN 6737 6752 6738 6753 var_get_id=td_var(ji)%i_id … … 6775 6790 IF( ASSOCIATED(td_var%d_value) )THEN 6776 6791 6777 CALL logger_trace( "VAR GET MASK: create mask from variable "//& 6778 & TRIM(td_var%c_name) ) 6792 CALL logger_debug( "VAR GET MASK: create mask from variable "//& 6793 & TRIM(td_var%c_name)//", FillValue ="//& 6794 & TRIM(fct_str(td_var%d_fill))) 6779 6795 var_get_mask(:,:,:)=1 6780 6796 WHERE( td_var%d_value(:,:,:,1) == td_var%d_fill ) … … 7279 7295 7280 7296 ! local variable 7297 CHARACTER(LEN=lc) :: cl_tmp 7298 7281 7299 INTEGER(i4) :: il_ind 7300 7282 7301 TYPE(TATT) :: tl_att 7283 7302 7284 7303 ! loop indices 7304 INTEGER(i4) :: ji 7285 7305 !---------------------------------------------------------------- 7286 7306 … … 7335 7355 td_var%c_axis=TRIM(tg_varextra(il_ind)%c_axis) 7336 7356 ! create attibute 7337 tl_att=att_init('axis',TRIM(td_var%c_axis)) 7338 CALL var_move_att(td_var, tl_att) 7357 IF( TRIM(fct_upper(td_var%c_name)) == TRIM(td_var%c_axis) )THEN 7358 tl_att=att_init('axis',TRIM(td_var%c_axis)) 7359 ELSE 7360 cl_tmp="" 7361 DO ji=LEN(TRIM(td_var%c_axis)),1,-1 7362 cl_tmp=TRIM(cl_tmp)//" "//TRIM(td_var%c_axis(ji:ji)) 7363 ENDDO 7364 tl_att=att_init('associate',TRIM(ADJUSTL(cl_tmp))) 7365 ENDIF 7366 CALL var_move_att(td_var, tl_att) 7339 7367 ENDIF 7340 7368 … … 7402 7430 ENDIF 7403 7431 7432 ELSE 7433 CALL logger_warn("VAR GET EXTRA: no extra information on "//& 7434 & "variable "//TRIM(td_var%c_name)//". you should define it"//& 7435 & " (see variable.cfg).") 7404 7436 ENDIF 7405 7437 … … 7425 7457 !> - change way to get information in namelist, 7426 7458 !> value follows string "min =" 7459 !> @date Feb, 2016 7460 !> - check character just after keyword 7427 7461 ! 7428 7462 !> @param[in] cd_name variable name … … 7447 7481 ! loop indices 7448 7482 INTEGER(i4) :: ji 7483 INTEGER(i4) :: jj 7449 7484 !---------------------------------------------------------------- 7450 7485 ! init … … 7457 7492 il_ind=INDEX(TRIM(cl_tmp),'min') 7458 7493 IF( il_ind /= 0 )THEN 7459 cl_min=fct_split(cl_tmp,2,'=') 7460 EXIT 7494 ! check character just after 7495 jj=il_ind+LEN('min') 7496 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 7497 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 7498 cl_min=fct_split(cl_tmp,2,'=') 7499 EXIT 7500 ENDIF 7461 7501 ENDIF 7462 7502 ji=ji+1 … … 7470 7510 & TRIM(fct_str(var__get_min))//" for variable "//TRIM(cd_name) ) 7471 7511 ELSE 7472 CALL logger_error("VAR GET MIN: invalid minimum value for "//& 7473 & "variable "//TRIM(cd_name)//". check namelist." ) 7512 CALL logger_error("VAR GET MIN: invalid minimum value ("//& 7513 & TRIM(cl_min)//") for variable "//TRIM(cd_name)//& 7514 & ". check namelist." ) 7474 7515 ENDIF 7475 7516 ENDIF … … 7489 7530 !> - change way to get information in namelist, 7490 7531 !> value follows string "max =" 7532 !> @date Feb, 2016 7533 !> - check character just after keyword 7491 7534 ! 7492 7535 !> @param[in] cd_name variable name … … 7511 7554 ! loop indices 7512 7555 INTEGER(i4) :: ji 7556 INTEGER(i4) :: jj 7513 7557 !---------------------------------------------------------------- 7514 7558 ! init … … 7521 7565 il_ind=INDEX(TRIM(cl_tmp),'max') 7522 7566 IF( il_ind /= 0 )THEN 7523 cl_max=fct_split(cl_tmp,2,'=') 7524 EXIT 7567 ! check character just after 7568 jj=il_ind+LEN('max') 7569 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 7570 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 7571 cl_max=fct_split(cl_tmp,2,'=') 7572 EXIT 7573 ENDIF 7525 7574 ENDIF 7526 7575 ji=ji+1 … … 7550 7599 !> @author J.Paul 7551 7600 !> @date June, 2015 - Initial Version 7601 !> @date Feb, 2016 7602 !> - check character just after keyword 7552 7603 ! 7553 7604 !> @param[in] cd_name variable name … … 7574 7625 ! loop indices 7575 7626 INTEGER(i4) :: ji 7627 INTEGER(i4) :: jj 7576 7628 !---------------------------------------------------------------- 7577 7629 ! init … … 7584 7636 il_ind=INDEX(TRIM(cl_tmp),'unf') 7585 7637 IF( il_ind /= 0 )THEN 7586 cl_unf=fct_split(cl_tmp,2,'=') 7587 EXIT 7638 ! check character just after 7639 jj=il_ind+LEN('unf') 7640 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 7641 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 7642 cl_unf=fct_split(cl_tmp,2,'=') 7643 EXIT 7644 ENDIF 7588 7645 ENDIF 7589 7646 ji=ji+1 … … 7626 7683 !> - change way to get information in namelist, 7627 7684 !> value follows string "int =" 7685 !> @date Feb, 2016 7686 !> - check character just after keyword 7628 7687 ! 7629 7688 !> @param[in] cd_name variable name … … 7663 7722 il_ind=INDEX(TRIM(cl_tmp),'int') 7664 7723 IF( il_ind /= 0 )THEN 7665 cl_int=fct_split(cl_tmp,2,'=') 7666 EXIT 7724 ! check character just after 7725 jj=il_ind+LEN('int') 7726 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 7727 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 7728 cl_int=fct_split(cl_tmp,2,'=') 7729 EXIT 7730 ENDIF 7667 7731 ENDIF 7668 7732 ji=ji+1 … … 7746 7810 !> - change way to get information in namelist, 7747 7811 !> value follows string "ext =" 7812 !> @date Feb, 2016 7813 !> - check character just after keyword 7748 7814 ! 7749 7815 !> @param[in] cd_name variable name … … 7778 7844 il_ind=INDEX(TRIM(cl_tmp),'ext') 7779 7845 IF( il_ind /= 0 )THEN 7780 cl_ext=fct_split(cl_tmp,2,'=') 7781 EXIT 7846 ! check character just after 7847 jj=il_ind+LEN('ext') 7848 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 7849 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 7850 cl_ext=fct_split(cl_tmp,2,'=') 7851 EXIT 7852 ENDIF 7782 7853 ENDIF 7783 7854 ji=ji+1 … … 7822 7893 !> - change way to get information in namelist, 7823 7894 !> value follows string "flt =" 7895 !> @date Feb, 2016 7896 !> - check character just after keyword 7824 7897 !> 7825 7898 !> @param[in] cd_name variable name … … 7852 7925 il_ind=INDEX(TRIM(cl_tmp),'flt') 7853 7926 IF( il_ind /= 0 )THEN 7854 cl_flt=fct_split(cl_tmp,2,'=') 7855 EXIT 7927 ! check character just after 7928 jj=il_ind+LEN('flt') 7929 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 7930 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 7931 cl_flt=fct_split(cl_tmp,2,'=') 7932 EXIT 7933 ENDIF 7856 7934 ENDIF 7857 7935 ji=ji+1 … … 7925 8003 !> @author J.Paul 7926 8004 !> @date June, 2015 - Initial Version 8005 !> @date Feb, 2016 8006 !> - check character just after keyword 7927 8007 ! 7928 8008 !> @param[in] cd_name variable name … … 7946 8026 ! loop indices 7947 8027 INTEGER(i4) :: ji 8028 INTEGER(i4) :: jj 7948 8029 !---------------------------------------------------------------- 7949 8030 … … 7955 8036 il_ind=INDEX(TRIM(cl_tmp),'unt') 7956 8037 IF( il_ind /= 0 )THEN 7957 var__get_unt=fct_split(cl_tmp,2,'=') 7958 EXIT 8038 ! check character just after 8039 jj=il_ind+LEN('unt') 8040 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 8041 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 8042 var__get_unt=fct_split(cl_tmp,2,'=') 8043 EXIT 8044 ENDIF 7959 8045 ENDIF 7960 8046 ji=ji+1 … … 8101 8187 8102 8188 !- change scale factor and offset to avoid mistake 8103 tl_att=att_init('scale_factor',1 )8189 tl_att=att_init('scale_factor',1._dp) 8104 8190 CALL var_move_att(td_var, tl_att) 8105 8191 8106 tl_att=att_init('add_offset',0 )8192 tl_att=att_init('add_offset',0._dp) 8107 8193 CALL var_move_att(td_var, tl_att) 8108 8194 ENDIF … … 8356 8442 8357 8443 END FUNCTION var_to_date 8444 !------------------------------------------------------------------- 8445 !> @brief This subroutine fill dummy variable array 8446 ! 8447 !> @author J.Paul 8448 !> @date September, 2015 - Initial Version 8449 ! 8450 !> @param[in] cd_dummy dummy configuration file 8451 !------------------------------------------------------------------- 8452 SUBROUTINE var_get_dummy( cd_dummy ) 8453 IMPLICIT NONE 8454 ! Argument 8455 CHARACTER(LEN=*), INTENT(IN) :: cd_dummy 8456 8457 ! local variable 8458 INTEGER(i4) :: il_fileid 8459 INTEGER(i4) :: il_status 8460 8461 LOGICAL :: ll_exist 8462 8463 ! loop indices 8464 ! namelist 8465 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumvar 8466 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumdim 8467 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumatt 8468 8469 !---------------------------------------------------------------- 8470 NAMELIST /namdum/ & !< dummy namelist 8471 & cn_dumvar, & !< variable name 8472 & cn_dumdim, & !< dimension name 8473 & cn_dumatt !< attribute name 8474 !---------------------------------------------------------------- 8475 8476 ! init 8477 cm_dumvar(:)='' 8478 8479 ! read namelist 8480 INQUIRE(FILE=TRIM(cd_dummy), EXIST=ll_exist) 8481 IF( ll_exist )THEN 8482 8483 il_fileid=fct_getunit() 8484 8485 OPEN( il_fileid, FILE=TRIM(cd_dummy), & 8486 & FORM='FORMATTED', & 8487 & ACCESS='SEQUENTIAL', & 8488 & STATUS='OLD', & 8489 & ACTION='READ', & 8490 & IOSTAT=il_status) 8491 CALL fct_err(il_status) 8492 IF( il_status /= 0 )THEN 8493 CALL logger_fatal("DIM GET DUMMY: opening "//TRIM(cd_dummy)) 8494 ENDIF 8495 8496 READ( il_fileid, NML = namdum ) 8497 cm_dumvar(:)=cn_dumvar(:) 8498 8499 CLOSE( il_fileid ) 8500 8501 ENDIF 8502 8503 END SUBROUTINE var_get_dummy 8504 !------------------------------------------------------------------- 8505 !> @brief This function check if variable is defined as dummy variable 8506 !> in configuraton file 8507 !> 8508 !> @author J.Paul 8509 !> @date September, 2015 - Initial Version 8510 ! 8511 !> @param[in] td_var variable structure 8512 !> @return true if variable is dummy variable 8513 !------------------------------------------------------------------- 8514 FUNCTION var_is_dummy(td_var) 8515 IMPLICIT NONE 8516 8517 ! Argument 8518 TYPE(TVAR), INTENT(IN) :: td_var 8519 8520 ! function 8521 LOGICAL :: var_is_dummy 8522 8523 ! loop indices 8524 INTEGER(i4) :: ji 8525 !---------------------------------------------------------------- 8526 8527 var_is_dummy=.FALSE. 8528 DO ji=1,ip_maxdum 8529 IF( fct_lower(td_var%c_name) == fct_lower(cm_dumvar(ji)) )THEN 8530 var_is_dummy=.TRUE. 8531 EXIT 8532 ENDIF 8533 ENDDO 8534 8535 END FUNCTION var_is_dummy 8358 8536 END MODULE var 8359 8537 -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/src/vgrid.f90
r5617 r7339 291 291 END SUBROUTINE vgrid_zgr_z 292 292 !------------------------------------------------------------------- 293 !> @brief This subroutine 294 !> 295 !> @todo add subroutine description 296 !> 297 !> @param[inout] dd_bathy 298 !> @param[in] dd_gdepw 299 !> @param[in] dd_hmin 300 !> @param[in] dd_fill 293 301 !------------------------------------------------------------------- 294 302 SUBROUTINE vgrid_zgr_bat( dd_bathy, dd_gdepw, dd_hmin, dd_fill ) … … 371 379 !> - gdept, gdepw and e3 are positives 372 380 !> - gdept_ps, gdepw_ps and e3_ps are positives 373 ! 381 !> 374 382 !> @author A. Bozec, G. Madec 375 383 !> @date February, 2009 - F90: Free form and module … … 386 394 !> @param[in] dd_e3zps_min 387 395 !> @param[in] dd_e3zps_rat 396 !> @param[in] dd_fill 388 397 !------------------------------------------------------------------- 389 398 SUBROUTINE vgrid_zgr_zps( id_mbathy, dd_bathy, id_jpkmax, & … … 495 504 !> ** Action : - update mbathy: level bathymetry (in level index) 496 505 !> - update bathy : meter bathymetry (in meters) 497 506 !> 498 507 !> @author G.Madec 499 508 !> @date Marsh, 2008 - Original code -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/templates/create_bathy.nam
r5609 r7339 1 1 &namlog 2 cn_logfile= "bathy_out.log"2 cn_logfile= 3 3 cn_verbosity= 4 4 in_maxerror= … … 6 6 7 7 &namcfg 8 cn_varcfg="./cfg/variable.cfg" 8 cn_varcfg= 9 cn_dumcfg= 9 10 / 10 11 … … 16 17 &namfin 17 18 cn_coord1= 19 in_perio1= 20 ln_fillclosed= 18 21 / 19 22 … … 29 32 30 33 &namout 31 cn_fileout= "bathy_out.nc"34 cn_fileout= 32 35 / -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/templates/create_boundary.nam
r5609 r7339 1 1 &namlog 2 cn_logfile= "boundary.log"2 cn_logfile= 3 3 cn_verbosity= 4 4 in_maxerror = … … 6 6 7 7 &namcfg 8 cn_varcfg="./cfg/variable.cfg" 8 cn_varcfg= 9 cn_dumcfg= 9 10 / 10 11 … … 41 42 42 43 &namvar 44 cn_varfile= 43 45 cn_varinfo= 44 cn_varfile=45 46 / 46 47 … … 63 64 64 65 &namout 65 cn_fileout= "boundary_out.nc"66 cn_fileout= 66 67 dn_dayofs= 67 68 ln_extrap= -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/templates/create_coord.nam
r5037 r7339 1 1 &namlog 2 cn_logfile= "coord_out.log"2 cn_logfile= 3 3 cn_verbosity= 4 4 in_maxerror= … … 6 6 7 7 &namcfg 8 cn_varcfg="./cfg/variable.cfg" 8 cn_varcfg= 9 cn_dumcfg= 9 10 / 10 11 … … 29 30 30 31 &namout 31 cn_fileout= "coord_out.nc"32 cn_fileout= 32 33 / 33 34 -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/templates/create_restart.nam
r5609 r7339 1 1 &namlog 2 cn_logfile= "restart_out.log"2 cn_logfile= 3 3 cn_verbosity= 4 in_maxerror 4 in_maxerror= 5 5 / 6 6 7 7 &namcfg 8 cn_varcfg="./cfg/variable.cfg" 8 cn_varcfg= 9 cn_dumcfg= 9 10 / 10 11 … … 41 42 42 43 &namvar 44 cn_varfile= 43 45 cn_varinfo= 44 cn_varfile=45 46 / 46 47 … … 51 52 52 53 &namout 53 cn_fileout= "restart_out.nc"54 cn_fileout= 54 55 ln_extrap= 55 in_nipro =56 in_niproc= 56 57 in_njproc= 57 58 in_nproc= -
branches/2016/dev_NOC_2016/NEMOGCM/TOOLS/SIREN/templates/merge_bathy.nam
r5037 r7339 1 1 &namlog 2 cn_logfile= "merge_out.log"2 cn_logfile= 3 3 cn_verbosity= 4 in_maxerror 4 in_maxerror= 5 5 / 6 6 7 7 &namcfg 8 cn_varcfg="./cfg/variable.cfg" 8 cn_varcfg= 9 cn_dumcfg= 9 10 / 10 11 … … 17 18 cn_bathy1= 18 19 in_perio1= 19 /20 21 &namvar22 cn_varinfo=23 20 / 24 21 … … 41 38 42 39 &namout 43 cn_fileout= "merge_out.nc"40 cn_fileout= 44 41 /
Note: See TracChangeset
for help on using the changeset viewer.